X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/afc4ccd4ddcf0f78932a5e0597731beb6efc8c7c..107139eaadab946e9713748cdeacd07b22a181db:/ice-9/boot-9.scm diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 3ecd7b596..bde0b852a 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006 +;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -92,9 +92,11 @@ ;; (eval-case ((situation*) forms)* (else forms)?) ;; ;; Evaluate certain code based on the situation that eval-case is used -;; in. The only defined situation right now is `load-toplevel' which -;; triggers for code evaluated at the top-level, for example from the -;; REPL or when loading a file. +;; in. There are three situations defined. `load-toplevel' triggers for +;; code evaluated at the top-level, for example from the REPL or when +;; loading a file. `compile-toplevel' triggers for code compiled at the +;; toplevel. `execute' triggers during execution of code not at the top +;; level. (define eval-case (procedure->memoizing-macro @@ -123,6 +125,14 @@ +;; Before compiling, make sure any symbols are resolved in the (guile) +;; module, the primary location of those symbols, rather than in +;; (guile-user), the default module that we compile in. + +(eval-case + ((compile-toplevel) + (set-current-module (resolve-module '(guile))))) + ;;; {Defmacros} ;;; ;;; Depends on: features, eval-case @@ -151,18 +161,12 @@ (lambda (name parms . body) (let ((transformer `(lambda ,parms ,@body))) `(eval-case - ((load-toplevel) - (define ,name (defmacro:transformer ,transformer))) + ((load-toplevel compile-toplevel) + (define ,name (defmacro:transformer ,transformer))) (else (error "defmacro can only be used at the top level"))))))) (defmacro:transformer defmacro-transformer))) -(define defmacro:syntax-transformer - (lambda (f) - (procedure->syntax - (lambda (exp env) - (copy-tree (apply f (cdr exp))))))) - ;; XXX - should the definition of the car really be looked up in the ;; current module? @@ -196,15 +200,15 @@ (defmacro begin-deprecated forms (if (include-deprecated-features) - (cons begin forms) - #f)) + `(begin ,@forms) + (begin))) ;;; {R4RS compliance} ;;; -(primitive-load-path "ice-9/r4rs.scm") +(primitive-load-path "ice-9/r4rs") @@ -327,22 +331,6 @@ -;;; {Environments} -;;; - -(define the-environment - (procedure->syntax - (lambda (x e) - e))) - -(define the-root-environment (the-environment)) - -(define (environment-module env) - (let ((closure (and (pair? env) (car (last-pair env))))) - (and closure (eval-closure-module closure)))) - - - ;;; {Records} ;;; @@ -418,18 +406,18 @@ (define (record-constructor rtd . opt) (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) - (local-eval `(lambda ,field-names - (make-struct ',rtd 0 ,@(map (lambda (f) - (if (memq f field-names) - f - #f)) - (record-type-fields rtd)))) - the-root-environment))) - + (primitive-eval + `(lambda ,field-names + (make-struct ',rtd 0 ,@(map (lambda (f) + (if (memq f field-names) + f + #f)) + (record-type-fields rtd))))))) + (define (record-predicate rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) -(define (%record-type-check rtd obj) ;; private helper +(define (%record-type-error rtd obj) ;; private helper (or (eq? rtd (record-type-descriptor obj)) (scm-error 'wrong-type-arg "%record-type-check" "Wrong type record (want `~S'): ~S" @@ -437,23 +425,22 @@ #f))) (define (record-accessor rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) + (let ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (local-eval `(lambda (obj) - (%record-type-check ',rtd obj) - (struct-ref obj ,pos)) - the-root-environment))) + (lambda (obj) + (if (eq? (struct-vtable obj) rtd) + (struct-ref obj pos) + (%record-type-error rtd obj))))) (define (record-modifier rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) + (let ((pos (list-index (record-type-fields rtd) field-name))) (if (not pos) (error 'no-such-field field-name)) - (local-eval `(lambda (obj val) - (%record-type-check ',rtd obj) - (struct-set! obj ,pos val)) - the-root-environment))) - + (lambda (obj val) + (if (eq? (struct-vtable obj) rtd) + (struct-set! obj pos val) + (%record-type-error rtd obj))))) (define (record? obj) (and (struct? obj) (record-type? (struct-vtable obj)))) @@ -536,10 +523,10 @@ (if (provided? 'posix) - (primitive-load-path "ice-9/posix.scm")) + (primitive-load-path "ice-9/posix")) (if (provided? 'socket) - (primitive-load-path "ice-9/networking.scm")) + (primitive-load-path "ice-9/networking")) ;; For reference, Emacs file-exists-p uses stat in this same way. ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in @@ -567,10 +554,7 @@ #f))))) (define (has-suffix? str suffix) - (let ((sufl (string-length suffix)) - (sl (string-length str))) - (and (> sl sufl) - (string=? (substring str (- sl sufl) sl) suffix)))) + (string-suffix? suffix str)) (define (system-error-errno args) (if (eq? (car args) 'system-error) @@ -766,6 +750,14 @@ +;;; {The interpreter stack} +;;; + +(defmacro start-stack (tag exp) + `(%start-stack ,tag (lambda () ,exp))) + + + ;;; {Loading by paths} ;;; @@ -1098,18 +1090,20 @@ ;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind ;;; is set, it defaults to 'module. ;;; -;;; - duplicates-handlers -;;; -;;; - duplicates-interface +;;; - duplicates-handlers: a list of procedures that get called to make a +;;; choice between two duplicate bindings when name clashes occur. See the +;;; `duplicate-handlers' global variable below. ;;; -;;; - observers +;;; - observers: a list of procedures that get called when the module is +;;; modified. ;;; -;;; - weak-observers -;;; -;;; - observer-id +;;; - weak-observers: a weak-key hash table of procedures that get called +;;; when the module is modified. See `module-observe-weak' for details. ;;; ;;; In addition, the module may (must?) contain a binding for -;;; %module-public-interface... More explanations here... +;;; `%module-public-interface'. This variable should be bound to a module +;;; representing the exported interface of a module. See the +;;; `module-public-interface' and `module-export!' procedures. ;;; ;;; !!! warning: The interface to lazy binder procedures is going ;;; to be changed in an incompatible way to permit all the basic @@ -1173,8 +1167,8 @@ (define module-type (make-record-type 'module '(obarray uses binder eval-closure transformer name kind - duplicates-handlers duplicates-interface - observers weak-observers observer-id) + duplicates-handlers import-obarray + observers weak-observers) %print-module)) ;; make-module &opt size uses binder @@ -1190,6 +1184,10 @@ (list-ref args index) default)) + (define %default-import-size + ;; Typical number of imported bindings actually used by a module. + 600) + (if (> (length args) 3) (error "Too many args to make-module." args)) @@ -1207,10 +1205,10 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-hash-table size) - uses binder #f #f #f #f #f #f + uses binder #f #f #f #f #f + (make-hash-table %default-import-size) '() - (make-weak-value-hash-table 31) - 0))) + (make-weak-key-hash-table 31)))) ;; We can't pass this as an argument to module-constructor, ;; because we need it to close over a pointer to the module @@ -1240,17 +1238,13 @@ (record-accessor module-type 'duplicates-handlers)) (define set-module-duplicates-handlers! (record-modifier module-type 'duplicates-handlers)) -(define module-duplicates-interface - (record-accessor module-type 'duplicates-interface)) -(define set-module-duplicates-interface! - (record-modifier module-type 'duplicates-interface)) (define module-observers (record-accessor module-type 'observers)) (define set-module-observers! (record-modifier module-type 'observers)) (define module-weak-observers (record-accessor module-type 'weak-observers)) -(define module-observer-id (record-accessor module-type 'observer-id)) -(define set-module-observer-id! (record-modifier module-type 'observer-id)) (define module? (record-predicate module-type)) +(define module-import-obarray (record-accessor module-type 'import-obarray)) + (define set-module-eval-closure! (let ((setter (record-modifier module-type 'eval-closure))) (lambda (module closure) @@ -1269,11 +1263,19 @@ (set-module-observers! module (cons proc (module-observers module))) (cons module proc)) -(define (module-observe-weak module proc) - (let ((id (module-observer-id module))) - (hash-set! (module-weak-observers module) id proc) - (set-module-observer-id! module (+ 1 id)) - (cons module id))) +(define (module-observe-weak module observer-id . proc) + ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can + ;; be any Scheme object). PROC is invoked and passed MODULE any time + ;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd + ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value, + ;; for instance). + + ;; The two-argument version is kept for backward compatibility: when called + ;; with two arguments, the observer gets unregistered when closure PROC + ;; gets GC'd (making it impossible to use an anonymous lambda for PROC). + + (let ((proc (if (null? proc) observer-id (car proc)))) + (hashq-set! (module-weak-observers module) observer-id proc))) (define (module-unobserve token) (let ((module (car token)) @@ -1311,7 +1313,11 @@ (define (module-call-observers m) (for-each (lambda (proc) (proc m)) (module-observers m)) - (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m))) + + ;; We assume that weak observers don't (un)register themselves as they are + ;; called since this would preclude proper iteration over the hash table + ;; elements. + (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m))) @@ -1435,26 +1441,8 @@ ;;; ;;; If the symbol is not found at all, return #f. ;;; -(define (module-local-variable m v) -; (caddr -; (list m v - (let ((b (module-obarray-ref (module-obarray m) v))) - (or (and (variable? b) b) - (and (module-binder m) - ((module-binder m) m v #f))))) -;)) - -;; module-variable module symbol -;; -;; like module-local-variable, except search the uses in the -;; case V is not found in M. -;; -;; NOTE: This function is superseded with C code (see modules.c) -;;; when using the standard eval closure. -;; -(define (module-variable m v) - (module-search module-local-variable m v)) - +;;; (This is now written in C, see `modules.c'.) +;;; ;;; {Mapping modules x symbols --> bindings} ;;; @@ -1515,19 +1503,10 @@ (module-modified m) b))) - ;; No local variable yet, so we need to create a new one. That - ;; new variable is initialized with the old imported value of V, - ;; if there is one. - (let ((imported-var (module-variable m v)) - (local-var (or (and (module-binder m) - ((module-binder m) m v #t)) - (begin - (let ((answer (make-undefined-variable))) - (module-add! m v answer) - answer))))) - (if (and imported-var (not (variable-bound? local-var))) - (variable-set! local-var (variable-ref imported-var))) - local-var))) + ;; Create a new local variable. + (let ((local-var (make-undefined-variable))) + (module-add! m v local-var) + local-var))) ;; module-ensure-local-variable! module symbol ;; @@ -1696,46 +1675,29 @@ ;; Add INTERFACE to the list of interfaces used by MODULE. ;; (define (module-use! module interface) - (set-module-uses! module - (cons interface - (filter (lambda (m) - (not (equal? (module-name m) - (module-name interface)))) - (module-uses module)))) - (module-modified module)) + (if (not (eq? module interface)) + (begin + ;; Newly used modules must be appended rather than consed, so that + ;; `module-variable' traverses the use list starting from the first + ;; used module. + (set-module-uses! module + (append (filter (lambda (m) + (not + (equal? (module-name m) + (module-name interface)))) + (module-uses module)) + (list interface))) + + (module-modified module)))) ;; MODULE-USE-INTERFACES! module interfaces ;; ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates ;; (define (module-use-interfaces! module interfaces) - (let* ((duplicates-handlers? (or (module-duplicates-handlers module) - (default-duplicate-binding-procedures))) - (uses (module-uses module))) - ;; remove duplicates-interface - (set! uses (delq! (module-duplicates-interface module) uses)) - ;; remove interfaces to be added - (for-each (lambda (interface) - (set! uses - (filter (lambda (m) - (not (equal? (module-name m) - (module-name interface)))) - uses))) - interfaces) - ;; add interfaces to use list - (set-module-uses! module uses) - (for-each (lambda (interface) - (and duplicates-handlers? - ;; perform duplicate checking - (process-duplicates module interface)) - (set! uses (cons interface uses)) - (set-module-uses! module uses)) - interfaces) - ;; add duplicates interface - (if (module-duplicates-interface module) - (set-module-uses! module - (cons (module-duplicates-interface module) uses))) - (module-modified module))) + (set-module-uses! module + (append (module-uses module) interfaces)) + (module-modified module)) @@ -1861,30 +1823,34 @@ (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))))) + ;; Import the default set of bindings (from the SCM module) in MODULE. + (module-use! module the-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 (nested-ref the-root-module full-name))) - (if already - ;; The module already exists... - (if (and (or (null? maybe-autoload) (car maybe-autoload)) - (not (module-public-interface already))) - ;; ...but we are told to load and it doesn't contain source, so - (begin - (try-load-module name) - already) - ;; simply return it. - already) - (begin - ;; Try to autoload it if we are told so - (if (or (null? maybe-autoload) (car maybe-autoload)) - (try-load-module name)) - ;; Get/create it. - (make-modules-in (current-module) full-name)))))) +(define resolve-module + (let ((the-root-module the-root-module)) + (lambda (name . maybe-autoload) + (if (equal? name '(guile)) + the-root-module + (let ((full-name (append '(%app modules) name))) + (let ((already (nested-ref the-root-module full-name))) + (if already + ;; The module already exists... + (if (and (or (null? maybe-autoload) (car maybe-autoload)) + (not (module-public-interface already))) + ;; ...but we are told to load and it doesn't contain source, so + (begin + (try-load-module name) + already) + ;; simply return it. + already) + (begin + ;; Try to autoload it if we are told so + (if (or (null? maybe-autoload) (car maybe-autoload)) + (try-load-module name)) + ;; Get/create it. + (make-modules-in (current-module) full-name))))))))) ;; Cheat. These bindings are needed by modules.c, but we don't want ;; to move their real definition here because that would be unnatural. @@ -1893,17 +1859,19 @@ (define process-define-module #f) (define process-use-modules #f) (define module-export! #f) - -;; This boots the module system. All bindings needed by modules.c -;; must have been defined by now. -;; -(set-current-module the-root-module) +(define default-duplicate-binding-procedures #f) (define %app (make-module 31)) (define app %app) ;; for backwards compatability + (local-define '(%app modules) (make-module 31)) (local-define '(%app modules guile) the-root-module) +;; This boots the module system. All bindings needed by modules.c +;; must have been defined by now. +;; +(set-current-module the-root-module) + ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) @@ -2024,88 +1992,98 @@ (error "unrecognized define-module argument" arg)))) (beautify-user-module! module) (let loop ((kws kws) - (reversed-interfaces '()) - (exports '()) - (re-exports '()) - (replacements '())) + (reversed-interfaces '()) + (exports '()) + (re-exports '()) + (replacements '()) + (autoloads '())) (if (null? kws) - (call-with-deferred-observers - (lambda () - (module-use-interfaces! module (reverse reversed-interfaces)) - (module-export! module exports) - (module-replace! module replacements) - (module-re-export! module re-exports))) - (case (car kws) - ((#:use-module #:use-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) - (loop (cddr kws) - (cons interface reversed-interfaces) - exports - re-exports - replacements))) - ((#:autoload) - (or (and (pair? (cdr kws)) (pair? (cddr kws))) - (unrecognized kws)) - (loop (cdddr kws) - (cons (make-autoload-interface module - (cadr kws) - (caddr kws)) - reversed-interfaces) - exports - re-exports - replacements)) - ((#:no-backtrace) - (set-system-module! module #t) - (loop (cdr kws) reversed-interfaces exports re-exports replacements)) - ((#:pure) - (purify-module! module) - (loop (cdr kws) reversed-interfaces exports re-exports replacements)) - ((#:duplicates) - (if (not (pair? (cdr kws))) - (unrecognized kws)) - (set-module-duplicates-handlers! - module - (lookup-duplicates-handlers (cadr kws))) - (loop (cddr kws) reversed-interfaces exports re-exports replacements)) - ((#:export #:export-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - (append (cadr kws) exports) - re-exports - replacements)) - ((#:re-export #:re-export-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - exports - (append (cadr kws) re-exports) - replacements)) - ((#:replace #:replace-syntax) - (or (pair? (cdr kws)) - (unrecognized kws)) - (loop (cddr kws) - reversed-interfaces - exports - re-exports - (append (cadr kws) replacements))) - (else - (unrecognized kws))))) + (call-with-deferred-observers + (lambda () + (module-use-interfaces! module (reverse reversed-interfaces)) + (module-export! module exports) + (module-replace! module replacements) + (module-re-export! module re-exports) + (if (not (null? autoloads)) + (apply module-autoload! module autoloads)))) + (case (car kws) + ((#:use-module #:use-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements + autoloads))) + ((#:autoload) + (or (and (pair? (cdr kws)) (pair? (cddr kws))) + (unrecognized kws)) + (loop (cdddr kws) + reversed-interfaces + exports + re-exports + replacements + (let ((name (cadr kws)) + (bindings (caddr kws))) + (cons* name bindings autoloads)))) + ((#:no-backtrace) + (set-system-module! module #t) + (loop (cdr kws) reversed-interfaces exports re-exports + replacements autoloads)) + ((#:pure) + (purify-module! module) + (loop (cdr kws) reversed-interfaces exports re-exports + replacements autoloads)) + ((#:duplicates) + (if (not (pair? (cdr kws))) + (unrecognized kws)) + (set-module-duplicates-handlers! + module + (lookup-duplicates-handlers (cadr kws))) + (loop (cddr kws) reversed-interfaces exports re-exports + replacements autoloads)) + ((#:export #:export-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + (append (cadr kws) exports) + re-exports + replacements + autoloads)) + ((#:re-export #:re-export-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + exports + (append (cadr kws) re-exports) + replacements + autoloads)) + ((#:replace #:replace-syntax) + (or (pair? (cdr kws)) + (unrecognized kws)) + (loop (cddr kws) + reversed-interfaces + exports + re-exports + (append (cadr kws) replacements) + autoloads)) + (else + (unrecognized kws))))) (run-hook module-defined-hook module) module)) @@ -2131,12 +2109,31 @@ (if (pair? autoload) (set-car! autoload i))) (module-local-variable i sym)))))) - (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f - '() (make-weak-value-hash-table 31) 0))) + (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f + (make-hash-table 0) '() (make-weak-value-hash-table 31)))) + +(define (module-autoload! module . args) + "Have @var{module} automatically load the module named @var{name} when one +of the symbols listed in @var{bindings} is looked up. @var{args} should be a +list of module-name/binding-list pairs, e.g., as in @code{(module-autoload! +module '(ice-9 q) '(make-q q-length))}." + (let loop ((args args)) + (cond ((null? args) + #t) + ((null? (cdr args)) + (error "invalid name+binding autoload list" args)) + (else + (let ((name (car args)) + (bindings (cadr args))) + (module-use! module (make-autoload-interface module + name bindings)) + (loop (cddr args))))))) + ;;; {Compiled module} -(define load-compiled #f) +(if (not (defined? 'load-compiled)) + (define load-compiled #f)) @@ -2166,14 +2163,20 @@ (lambda () (autoload-in-progress! dir-hint name)) (lambda () (let ((file (in-vicinity dir-hint name))) - (cond ((and load-compiled - (%search-load-path (string-append file ".go"))) - => (lambda (full) - (load-file load-compiled full))) - ((%search-load-path file) - => (lambda (full) - (with-fluids ((current-reader #f)) - (load-file primitive-load full))))))) + (let ((compiled (and load-compiled + (%search-load-path + (string-append file ".go")))) + (source (%search-load-path file))) + (cond ((and source + (or (not compiled) + (< (stat:mtime (stat compiled)) + (stat:mtime (stat source))))) + (if compiled + (warn "source file" source "newer than" compiled)) + (with-fluids ((current-reader #f)) + (load-file primitive-load source))) + (compiled + (load-file load-compiled compiled)))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) @@ -2214,23 +2217,11 @@ ;;; {Run-time options} ;;; -(define define-option-interface +(defmacro define-option-interface (option-group) (let* ((option-name car) (option-value cadr) (option-documentation caddr) - (print-option (lambda (option) - (display (option-name option)) - (if (< (string-length - (symbol->string (option-name option))) - 8) - (display #\tab)) - (display #\tab) - (display (option-value option)) - (display #\tab) - (display (option-documentation option)) - (newline))) - ;; Below follow the macros defining the run-time option interfaces. (make-options (lambda (interface) @@ -2238,8 +2229,19 @@ (cond ((null? args) (,interface)) ((list? (car args)) (,interface (car args)) (,interface)) - (else (for-each ,print-option - (,interface #t))))))) + (else (for-each + (lambda (option) + (display (option-name option)) + (if (< (string-length + (symbol->string (option-name option))) + 8) + (display #\tab)) + (display #\tab) + (display (option-value option)) + (display #\tab) + (display (option-documentation option)) + (newline)) + (,interface #t))))))) (make-enable (lambda (interface) `(lambda flags @@ -2254,22 +2256,19 @@ flags) (,interface options) (,interface)))))) - (procedure->memoizing-macro - (lambda (exp env) - (let* ((option-group (cadr exp)) - (interface (car option-group)) - (options/enable/disable (cadr option-group))) - `(begin - (define ,(car options/enable/disable) - ,(make-options interface)) - (define ,(cadr options/enable/disable) - ,(make-enable interface)) - (define ,(caddr options/enable/disable) - ,(make-disable interface)) - (defmacro ,(caaddr option-group) (opt val) - `(,,(car options/enable/disable) - (append (,,(car options/enable/disable)) - (list ',opt ,val)))))))))) + (let* ((interface (car option-group)) + (options/enable/disable (cadr option-group))) + `(begin + (define ,(car options/enable/disable) + ,(make-options interface)) + (define ,(cadr options/enable/disable) + ,(make-enable interface)) + (define ,(caddr options/enable/disable) + ,(make-disable interface)) + (defmacro ,(caaddr option-group) (opt val) + `(,',(car options/enable/disable) + (append (,',(car options/enable/disable)) + (list ',opt ,val)))))))) (define-option-interface (eval-options-interface @@ -2525,7 +2524,7 @@ ;;; the readline library. (define repl-reader (lambda (prompt) - (display prompt) + (display (if (string? prompt) prompt (prompt))) (force-output) (run-hook before-read-hook) ((or (fluid-ref current-reader) read) (current-input-port)))) @@ -2709,24 +2708,12 @@ (car rest) `(lambda ,(cdr first) ,@rest)))) `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (define ,name (defmacro:transformer ,transformer))) (else (error "define-macro can only be used at the top level"))))) -(defmacro define-syntax-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-case - ((load-toplevel) - (define ,name (defmacro:syntax-transformer ,transformer))) - (else - (error "define-syntax-macro can only be used at the top level"))))) - ;;; {While} @@ -2751,18 +2738,18 @@ ;; This is probably a bug in syncase. ;; (define-macro (while cond . body) - (define (while-helper proc) - (do ((key (make-symbol "while-key"))) - ((catch key - (lambda () - (proc (lambda () (throw key #t)) - (lambda () (throw key #f)))) - (lambda (key arg) arg))))) - `(,while-helper (,lambda (break continue) - (do () - ((,not ,cond)) - ,@body) - #t))) + (let ((key (make-symbol "while-key"))) + `(do () + ((catch ',key + (lambda () + (let ((break (lambda () (throw ',key #t))) + (continue (lambda () (throw ',key #f)))) + (do () + ((not ,cond)) + ,@body) + #t)) + (lambda (key arg) + arg)))))) @@ -2773,6 +2760,11 @@ ;; Return a list of expressions that evaluate to the appropriate ;; arguments for resolve-interface according to SPEC. +(eval-case + ((compile-toplevel) + (if (memq 'prefix (read-options)) + (error "boot-9 must be compiled with #:kw, not :kw")))) + (define (compile-interface-spec spec) (define (make-keyarg sym key quote?) (cond ((or (memq sym spec) @@ -2837,7 +2829,7 @@ (defmacro define-module args `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (let ((m (process-define-module (list ,@(compile-define-module-args args))))) (set-current-module m) @@ -2862,7 +2854,7 @@ (defmacro use-modules modules `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (process-use-modules (list ,@(map (lambda (m) `(list ,@(compile-interface-spec m))) @@ -2873,7 +2865,7 @@ (defmacro use-syntax (spec) `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) ,@(if (pair? spec) `((process-use-modules (list (list ,@(compile-interface-spec spec)))) @@ -2903,7 +2895,7 @@ (let ((name (defined-name (car args)))) `(begin (define-private ,@args) - (eval-case ((load-toplevel) (export ,name)))))))) + (eval-case ((load-toplevel compile-toplevel) (export ,name)))))))) (defmacro defmacro-public args (define (syntax) @@ -2918,7 +2910,7 @@ (#t (let ((name (defined-name (car args)))) `(begin - (eval-case ((load-toplevel) (export-syntax ,name))) + (eval-case ((load-toplevel compile-toplevel) (export-syntax ,name))) (defmacro ,@args)))))) ;; Export a local variable @@ -2957,7 +2949,7 @@ (defmacro export names `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (call-with-deferred-observers (lambda () (module-export! (current-module) ',names)))) @@ -2966,7 +2958,7 @@ (defmacro re-export names `(eval-case - ((load-toplevel) + ((load-toplevel compile-toplevel) (call-with-deferred-observers (lambda () (module-re-export! (current-module) ',names)))) @@ -2991,6 +2983,7 @@ ;; Indeed, all references to global variables are memoized into such ;; variable objects. +;; FIXME: these don't work with the compiler (define-macro (@ mod-name var-name) (let ((var (module-variable (resolve-interface mod-name) var-name))) (if (not var) @@ -3062,7 +3055,7 @@ #f)) (define (warn module name int1 val1 int2 val2 var val) - (format #t + (format (current-error-port) "WARNING: ~A: `~A' imported from both ~A and ~A\n" (module-name module) name @@ -3084,7 +3077,7 @@ (define (warn-override-core module name int1 val1 int2 val2 var val) (and (eq? int1 the-scm-module) (begin - (format #t + (format (current-error-port) "WARNING: ~A: imported module ~A overrides core binding `~A'\n" (module-name module) (module-name int2) @@ -3133,57 +3126,6 @@ (lookup-duplicates-handlers handler-names)) handler-names))) -(define (make-duplicates-interface) - (let ((m (make-module))) - (set-module-kind! m 'custom-interface) - (set-module-name! m 'duplicates) - m)) - -(define (process-duplicates module interface) - (let* ((duplicates-handlers (or (module-duplicates-handlers module) - (default-duplicate-binding-procedures))) - (duplicates-interface (module-duplicates-interface module))) - (module-for-each - (lambda (name var) - (cond ((module-import-interface module name) - => - (lambda (prev-interface) - (let ((var1 (module-local-variable prev-interface name)) - (var2 (module-local-variable interface name))) - (if (not (eq? var1 var2)) - (begin - (if (not duplicates-interface) - (begin - (set! duplicates-interface - (make-duplicates-interface)) - (set-module-duplicates-interface! - module - duplicates-interface))) - (let* ((var (module-local-variable duplicates-interface - name)) - (val (and var - (variable-bound? var) - (variable-ref var)))) - (let loop ((duplicates-handlers duplicates-handlers)) - (cond ((null? duplicates-handlers)) - (((car duplicates-handlers) - module - name - prev-interface - (and (variable-bound? var1) - (variable-ref var1)) - interface - (and (variable-bound? var2) - (variable-ref var2)) - var - val) - => - (lambda (var) - (module-add! duplicates-interface name var))) - (else - (loop (cdr duplicates-handlers))))))))))))) - interface))) - ;;; {`cond-expand' for SRFI-0 support.} @@ -3313,13 +3255,11 @@ ;; numbers, which are the numbers of the SRFIs to be loaded on startup. ;; (define (use-srfis srfis) - (let lp ((s srfis)) - (if (pair? s) - (let* ((srfi (string->symbol - (string-append "srfi-" (number->string (car s))))) - (mod-i (resolve-interface (list 'srfi srfi)))) - (module-use! (current-module) mod-i) - (lp (cdr s)))))) + (process-use-modules + (map (lambda (num) + (list (list 'srfi (string->symbol + (string-append "srfi-" (number->string num)))))) + srfis))) @@ -3387,30 +3327,37 @@ ;; Use some convenient modules (in reverse order) - (if (provided? 'regex) - (module-use! guile-user-module (resolve-interface '(ice-9 regex)))) - (if (provided? 'threads) - (module-use! guile-user-module (resolve-interface '(ice-9 threads)))) - ;; load debugger on demand - (module-use! guile-user-module - (make-autoload-interface guile-user-module - '(ice-9 debugger) '(debug))) - (module-use! guile-user-module (resolve-interface '(ice-9 session))) - (module-use! guile-user-module (resolve-interface '(ice-9 debug))) - ;; so that builtin bindings will be checked first - (module-use! guile-user-module (resolve-interface '(ice-9 r5rs))) - (module-use! guile-user-module (resolve-interface '(guile))) - (set-current-module guile-user-module) + (process-use-modules + (append + '(((ice-9 r5rs)) + ((ice-9 session)) + ((ice-9 debug))) + (if (provided? 'regex) + '(((ice-9 regex))) + '()) + (if (provided? 'threads) + '(((ice-9 threads))) + '()))) + ;; load debugger on demand + (module-autoload! guile-user-module '(ice-9 debugger) '(debug)) + ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see + ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have + ;; no effect. (let ((old-handlers #f) + (start-repl (module-ref (resolve-interface '(system repl repl)) + 'start-repl)) (signals (if (provided? 'posix) `((,SIGINT . "User interrupt") (,SIGFPE . "Arithmetic error") - (,SIGBUS . "Bad memory access (bus error)") (,SIGSEGV . "Bad memory access (Segmentation violation)")) '()))) + ;; no SIGBUS on mingw + (if (defined? 'SIGBUS) + (set! signals (acons SIGBUS "Bad memory access (bus error)" + signals))) (dynamic-wind @@ -3435,7 +3382,7 @@ ;; the protected thunk. (lambda () - (let ((status (scm-style-repl))) + (let ((status (start-repl 'scheme))) (run-hook exit-hook) status)) @@ -3467,7 +3414,7 @@ (provided? sym))) (begin-deprecated - (primitive-load-path "ice-9/deprecated.scm")) + (primitive-load-path "ice-9/deprecated"))