;;; installed-scm-file
-;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
\f
-;;; {and-map, or-map, and map-in-order}
+;;; {Multiple return values}
+
+(define *values-rtd*
+ (make-record-type "values"
+ '(values)))
+
+(define values
+ (let ((make-values (record-constructor *values-rtd*)))
+ (lambda x
+ (if (and (not (null? x))
+ (null? (cdr x)))
+ (car x)
+ (make-values x)))))
+
+(define call-with-values
+ (let ((access-values (record-accessor *values-rtd* 'values))
+ (values-predicate? (record-predicate *values-rtd*)))
+ (lambda (producer consumer)
+ (let ((result (producer)))
+ (if (values-predicate? result)
+ (apply consumer (access-values result))
+ (consumer result))))))
+
+
+\f
+;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
(and (not (null? l))
(loop (f (car l)) (cdr l))))))
-;; map-in-order
-;;
-;; Like map, but guaranteed to process the list in order.
-;;
-(define (map-in-order fn l)
- (if (null? l)
- '()
- (cons (fn (car l))
- (map-in-order fn (cdr l)))))
-
\f
;;; {Hooks}
+;;;
+;;; Warning: Hooks are now first class objects and add-hook! and remove-hook!
+;;; procedures. This interface is only provided for backward compatibility
+;;; and will be removed.
+;;;
+(if (not (defined? 'new-add-hook!))
+ (begin
+ (define new-add-hook! add-hook!)
+ (define new-remove-hook! remove-hook!)))
+
(define (run-hooks hook)
- (for-each (lambda (thunk) (thunk)) hook))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ (run-hook hook)
+ (for-each (lambda (thunk) (thunk)) hook)))
(define add-hook!
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
- `(let ((thunk ,(caddr exp)))
- (if (not (memq thunk ,(cadr exp)))
- (set! ,(cadr exp)
- (cons thunk ,(cadr exp))))))))
+ (let ((hook (local-eval (cadr exp) env)))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ `(new-add-hook! ,@(cdr exp))
+ (begin
+ (display "Warning: Old style hooks\n" (current-error-port))
+ `(let ((thunk ,(caddr exp)))
+ (if (not (memq thunk ,(cadr exp)))
+ (set! ,(cadr exp)
+ (cons thunk ,(cadr exp)))))))))))
(define remove-hook!
- (procedure->macro
+ (procedure->memoizing-macro
(lambda (exp env)
- `(let ((thunk ,(caddr exp)))
- (if (memq thunk ,(cadr exp))
- (set! ,(cadr exp)
- (delq! thunk ,(cadr exp))))))))
+ (let ((hook (local-eval (cadr exp) env)))
+ (if (and (pair? hook) (eq? (car hook) 'hook))
+ `(new-remove-hook! ,@(cdr exp))
+ (begin
+ (display "Warning: Old style hooks\n" (current-error-port))
+ `(let ((thunk ,(caddr exp)))
+ (set! ,(cadr exp)
+ (delq! thunk ,(cadr exp))))))))))
\f
;;; {Files}
(loop (cons (read-component) reversed-path)))
(reverse reversed-path))))))
+(define (read-path-list-notation-warning slash port)
+ (if (not (getenv "GUILE_HUSH"))
+ (begin
+ (display "warning: obsolete `#/' list notation read from "
+ (current-error-port))
+ (display (port-filename port) (current-error-port))
+ (display "; see guile-core/NEWS." (current-error-port))
+ (newline (current-error-port))
+ (display " Set the GUILE_HUSH environment variable to disable this warning."
+ (current-error-port))
+ (newline (current-error-port))))
+ (read-hash-extend #\/ read-path-list-notation)
+ (read-path-list-notation slash port))
+
+
(read-hash-extend #\' (lambda (c port)
(read port)))
(read-hash-extend #\. (lambda (c port)
(for-each (lambda (char template)
(read-hash-extend char
(make-array-proc template)))
- '(#\b #\a #\u #\e #\s #\i #\c)
- '(#t #\a 1 -1 1.0 1/3 0+i)))
+ '(#\b #\a #\u #\e #\s #\i #\c #\y #\h)
+ '(#t #\a 1 -1 1.0 1/3 0+i #\nul s)))
(let ((array-proc (lambda (c port)
(read:array c port))))
(for-each (lambda (char) (read-hash-extend char array-proc))
;; pushed to the beginning of the alist since it's used more than the
;; others at present.
-(read-hash-extend #\/ read-path-list-notation)
+(read-hash-extend #\/ read-path-list-notation-warning)
(define (read:array digit port)
(define chr0 (char->integer #\0))
(define set-module-uses! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define set-module-binder! (record-modifier module-type 'binder))
+
+;; NOTE: This binding is used in libguile/modules.c.
(define module-eval-closure (record-accessor module-type 'eval-closure))
+
(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
;; the-module
-;;
+;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define the-module #f)
;; scm:eval-transformer
;;
;; set the current module as viewed by the normalizer.
;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (set-current-module m)
(set! the-module m)
(if m
;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (resolve-module name . maybe-autoload)
(let ((full-name (append '(app modules) name)))
(let ((already (local-ref full-name)))
- (or already
- (begin
- (if (or (null? maybe-autoload) (car maybe-autoload))
- (or (try-module-linked name)
- (try-module-autoload name)
- (try-module-dynamic-link name)))
- (make-modules-in (current-module) full-name))))))
+ (or already
+ (begin
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (or (try-module-linked name)
+ (try-module-autoload name)
+ (try-module-dynamic-link name)))
+ (make-modules-in (current-module) full-name))))))
(define (beautify-user-module! module)
- (if (not (module-public-interface module))
- (let ((interface (make-module 31)))
- (set-module-name! interface (module-name module))
- (set-module-kind! interface 'interface)
- (set-module-public-interface! module interface)))
+ (let ((interface (module-public-interface module)))
+ (if (or (not interface)
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
(set-module-uses! module (append (module-uses module) (list the-scm-module)))))
+;; NOTE: This binding is used in libguile/modules.c.
+;;
(define (make-modules-in module name)
(if (null? name)
module
(cond
- ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
+ ((module-ref module (car name) #f)
+ => (lambda (m) (make-modules-in m (cdr name))))
(else (let ((m (make-module 31)))
(set-module-kind! m 'directory)
(set-module-name! m (car name))
(error "unrecognized defmodule argument" kws))
(let* ((used-name (cadr kws))
(used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
+ (if (eq? used-module module)
(begin
- ((if %autoloader-developer-mode warn error)
- "no code for module" (module-name used-module))
- (beautify-user-module! used-module)))
- (let ((interface (module-public-interface used-module)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (if (eq? keyword 'use-syntax)
- (internal-use-syntax
- (module-ref interface (car (last-pair used-name))
- #f)))
- (loop (cddr kws) (cons interface reversed-interfaces)))))
+ (or (try-module-linked used-name)
+ (try-module-dynamic-link used-name))
+ (loop (cddr kws) reversed-interfaces))
+ (begin
+ (if (not (module-ref used-module
+ '%module-public-interface
+ #f))
+ (begin
+ ((if %autoloader-developer-mode warn error)
+ "no code for module" (module-name used-module))
+ (beautify-user-module! used-module)))
+ (let ((interface (module-public-interface used-module)))
+ (if (not interface)
+ (error "missing interface for use-module"
+ used-module))
+ (if (eq? keyword 'use-syntax)
+ (internal-use-syntax
+ (module-ref interface (car (last-pair used-name))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)))))))
(else
(error "unrecognized defmodule argument" kws))))))
module))
(c-clear-registered-modules)
res))
-(define registered-modules (convert-c-registered-modules #f))
-
+(define registered-modules '())
+
+(define (register-modules dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules)))
+
(define (init-dynamic-module modname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(or-map (lambda (modinfo)
(if (equal? (car modinfo) modname)
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- (set-module-public-interface! mod mod)))
+ (begin
(set! registered-modules (delq! modinfo registered-modules))
- #t)
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (set-module-public-interface! mod mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ ))
+ #t))
#f))
registered-modules))
(check-dirs (cdr dir-list)))))))))
(define (try-using-libtool-name libdir libname)
- ;; FIXME: is `use-modules' legal inside `define'?
- (use-modules (ice-9 regex))
(let ((libtool-filename (in-vicinity libdir
(string-append libname ".la"))))
(and (file-exists? libtool-filename)
- (let ((dlname-pattern (make-regexp "^dlname='(.*)'")))
- (with-input-from-file libtool-filename
- (lambda ()
- (let loop ((ln (read-line)))
- (cond ((eof-object? ln) #f)
- ((regexp-exec dlname-pattern ln)
- => (lambda (match)
- (in-vicinity libdir (match:substring match 1))))
- (else (loop (read-line)))))))))))
+ (with-input-from-file libtool-filename
+ (lambda ()
+ (let loop ((ln (read-line)))
+ (cond ((eof-object? ln) #f)
+ ((and (> (string-length ln) 9)
+ (string=? "dlname='" (substring ln 0 8))
+ (string-index ln #\' 8))
+ =>
+ (lambda (end)
+ (in-vicinity libdir (substring ln 8 end))))
+ (else (loop (read-line))))))))))
(define (try-using-sharlib-name libdir libname)
(in-vicinity libdir (string-append libname ".so")))
(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which has been registered on the C level
+ (register-modules #f)
(let ((dynobj (dynamic-link filename)))
(dynamic-call initname dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules))))
+ (register-modules dynobj)))
(define (try-module-linked module-name)
(init-dynamic-module module-name))
(print-options-interface
(print-options print-enable print-disable)
(print-set!))
+
+ (readline-options-interface
+ (readline-options readline-enable readline-disable)
+ (readline-set!))
))
(option-name car)
(option-value cadr)
(make-options (lambda (interface)
`(lambda args
(cond ((null? args) (,interface))
- ((pair? (car args))
+ ((list? (car args))
(,interface (car args)) (,interface))
(else (for-each ,print-option
(,interface #t)))))))
(save-stack lazy-handler-dispatch)
(apply throw key args))
+(define enter-frame-handler default-lazy-handler)
(define apply-frame-handler default-lazy-handler)
(define exit-frame-handler default-lazy-handler)
(apply apply-frame-handler key args))
((exit-frame)
(apply exit-frame-handler key args))
+ ((enter-frame)
+ (apply enter-frame-handler key args))
(else
(apply default-lazy-handler key args))))
-(define abort-hook '())
+(define abort-hook (make-hook))
;; these definitions are used if running a script.
;; otherwise redefined in error-catching-loop.
(dynamic-wind
(lambda () (unmask-signals))
(lambda ()
- (first)
+ (with-traps
+ (lambda ()
+ (first)
- ;; This line is needed because mark
- ;; doesn't do closures quite right.
- ;; Unreferenced locals should be
- ;; collected.
- ;;
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ ;;
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))
(lambda () (mask-signals))))
lazy-handler-dispatch))
;; (set! first #f) above
;;
(lambda ()
- (run-hooks abort-hook)
+ (run-hook abort-hook)
(force-output)
(display "ABORT: " (current-error-port))
(write args (current-error-port))
(apply make-stack #t save-stack id narrowing))))))
(set! stack-saved? #t))))
-(define before-error-hook '())
-(define after-error-hook '())
-(define before-backtrace-hook '())
-(define after-backtrace-hook '())
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))
(define has-shown-debugger-hint? #f)
(let ((cep (current-error-port)))
(cond ((not (stack? (fluid-ref the-last-stack))))
((memq 'backtrace (debug-options-interface))
- (run-hooks before-backtrace-hook)
+ (run-hook before-backtrace-hook)
(newline cep)
(display-backtrace (fluid-ref the-last-stack) cep)
(newline cep)
- (run-hooks after-backtrace-hook)))
- (run-hooks before-error-hook)
+ (run-hook after-backtrace-hook)))
+ (run-hook before-error-hook)
(apply display-error (fluid-ref the-last-stack) cep args)
- (run-hooks after-error-hook)
+ (run-hook after-error-hook)
(force-output cep)
(throw 'abort key)))
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
-(define before-read-hook '())
-(define after-read-hook '())
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(lambda (prompt)
(display prompt)
(force-output)
- (run-hooks before-read-hook)
+ (run-hook before-read-hook)
(read (current-input-port))))
(define (scm-style-repl)
;; trailing newline here, as well as any whitespace
;; before it.
(consume-trailing-whitespace)
- (run-hooks after-read-hook)
+ (run-hook after-read-hook)
(if (eof-object? val)
(begin
(repl-report-start-timing)
(lambda () (continue))
(lambda v (cadr v)))))
+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;; (The definition relies on the current left-to-right
+;;; order of evaluation of operands in applications.)
+
+(defmacro collect forms
+ (cons 'list forms))
;;; {with-fluids}
`(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
(lambda () ,@body)))
+;;; Environments
+
+(define the-environment
+ (procedure->syntax
+ (lambda (x e)
+ e)))
+
\f
;;; {Macros}
(defmacro ,@ args))))))
+(defmacro export names
+ `(let* ((m (current-module))
+ (public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ ;; Make sure there is a local variable:
+ (module-define! m name (module-ref m name #f))
+ ;; Make sure that local is exported:
+ (module-add! public-i name (module-variable m name)))
+ ',names)))
+
+(define export-syntax export)
+
+
(define load load-module)
\f
+;;; {Load emacs interface support if emacs option is given.}
+
+(define (load-emacs-interface)
+ (if (memq 'debug-extensions *features*)
+ (debug-enable 'backtrace))
+ (define-module (guile-user) :use-module (ice-9 emacs)))
+
+\f
;;; {I/O functions for Tcl channels (disabled)}
;; (define in-ch (get-standard-channel TCL_STDIN))
;; this is just (scm-style-repl) with a wrapper to install and remove
;; signal handlers.
(define (top-repl)
+
+ ;; Load emacs interface support if emacs option is given.
+ (if (and (module-defined? the-root-module 'use-emacs-interface)
+ use-emacs-interface)
+ (load-emacs-interface))
+
+ ;; Place the user in the guile-user module.
+ (define-module (guile-user))
+
(let ((old-handlers #f)
(signals `((,SIGINT . "User interrupt")
(,SIGFPE . "Arithmetic error")
(not (and (module-defined? the-root-module
'use-emacs-interface)
use-emacs-interface)))
- (let ((read-hook (lambda () (run-hooks before-read-hook))))
+ (let ((read-hook (lambda () (run-hook before-read-hook))))
(set-current-input-port (readline-port))
(set! repl-reader
(lambda (prompt)
(lambda ()
(set-readline-prompt! "")
(set-readline-read-hook! #f)))))))
- (scm-style-repl))
+ (let ((status (scm-style-repl)))
+ (run-hook exit-hook)
+ status))
;; call at exit.
(lambda ()
`(catch #t (lambda () ,expr)
(lambda args #f)))
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
;;; Load readline code into root module if readline primitives are available.
;;;
;;; Ideally, we wouldn't do this until we were sure we were actually
(isatty? (current-input-port)))
(begin
(define-module (guile) :use-module (ice-9 readline))
- (define-module (user) :use-module (ice-9 readline))))
+ (define-module (guile-user) :use-module (ice-9 readline))))
\f
;;; {Load debug extension code into user module if debug extensions present.}
;;;
(if (memq 'debug-extensions *features*)
- (define-module (user) :use-module (ice-9 debug)))
+ (define-module (guile-user) :use-module (ice-9 debug)))
\f
;;; {Load session support into user module if present.}
;;;
(if (%search-load-path "ice-9/session.scm")
- (define-module (user) :use-module (ice-9 session)))
+ (define-module (guile-user) :use-module (ice-9 session)))
;;; {Load thread code into user module if threads are present.}
;;;
;;;
(if (memq 'threads *features*)
- (define-module (user) :use-module (ice-9 threads)))
-
-\f
-;;; {Load emacs interface support if emacs option is given.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (and (module-defined? the-root-module 'use-emacs-interface)
- use-emacs-interface)
- (begin
- (if (memq 'debug-extensions *features*)
- (debug-enable 'backtrace))
- (define-module (user) :use-module (ice-9 emacs))))
+ (define-module (guile-user) :use-module (ice-9 threads)))
\f
;;; {Load regexp code if regexp primitives are available.}
(if (memq 'regex *features*)
- (define-module (user) :use-module (ice-9 regex)))
+ (define-module (guile-user) :use-module (ice-9 regex)))
\f
(define-module (guile))
(append! %load-path (cons "." ()))
-\f
-
-(define-module (user))
HCoop / bpt / guile.git / blobdiff