X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/062fccce799bd874bcab541a8641682f85a06135..107139eaadab946e9713748cdeacd07b22a181db:/ice-9/boot-9.scm

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 0cc341a19..bde0b852a 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1,6 +1,7 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003, 2004 Free Software Foundation, Inc.
+;;;; 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
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -14,8 +15,9 @@
 ;;;; 
 ;;;; You should have received a copy of the GNU Lesser General Public
 ;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 ;;;;
+
 
 
 ;;; Commentary:
@@ -30,58 +32,188 @@
 ;;; Code:
 
 
-;;; {Deprecation}
-;;;
-
-;; We don't have macros here, but we do want to define
-;; `begin-deprecated' early.
-
-(define begin-deprecated
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (if (include-deprecated-features)
-	 `(begin ,@(cdr exp))
-	 `#f))))
 
-
 ;;; {Features}
-;;
+;;;
 
 (define (provide sym)
   (if (not (memq sym *features*))
       (set! *features* (cons sym *features*))))
 
-;;; Return #t iff FEATURE is available to this Guile interpreter.
-;;; In SLIB, provided? also checks to see if the module is available.
-;;; We should do that too, but don't.
+;; Return #t iff FEATURE is available to this Guile interpreter.  In SLIB,
+;; provided? also checks to see if the module is available.  We should do that
+;; too, but don't.
+
 (define (provided? feature)
   (and (memq feature *features*) #t))
 
-(begin-deprecated
- (define (feature? sym)
-   (issue-deprecation-warning
-    "`feature?' is deprecated.  Use `provided?' instead.")
-   (provided? sym)))
+;; let format alias simple-format until the more complete version is loaded
 
-;;; let format alias simple-format until the more complete version is loaded
 (define format simple-format)
 
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define (string-any char_pred s . rest)
+  (let ((start (if (null? rest)
+		   0 (car rest)))
+	(end   (if (or (null? rest) (null? (cdr rest)))
+		   (string-length s) (cadr rest))))
+    (if (and (procedure? char_pred)
+	     (> end start)
+	     (<= end (string-length s))) ;; let c-code handle range error
+	(or (string-any-c-code char_pred s start (1- end))
+	    (char_pred (string-ref s (1- end))))
+	(string-any-c-code char_pred s start end))))
+
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define (string-every char_pred s . rest)
+  (let ((start (if (null? rest)
+		   0 (car rest)))
+	(end   (if (or (null? rest) (null? (cdr rest)))
+		   (string-length s) (cadr rest))))
+    (if (and (procedure? char_pred)
+	     (> end start)
+	     (<= end (string-length s))) ;; let c-code handle range error
+	(and (string-every-c-code char_pred s start (1- end))
+	     (char_pred (string-ref s (1- end))))
+	(string-every-c-code char_pred s start end))))
+
+;; A variant of string-fill! that we keep for compatability
+;;
+(define (substring-fill! str start end fill)
+  (string-fill! str fill start end))
+
 
-;;; {R4RS compliance}
 
-(primitive-load-path "ice-9/r4rs.scm")
+;;; {EVAL-CASE}
+;;;
+
+;; (eval-case ((situation*) forms)* (else forms)?)
+;;
+;; Evaluate certain code based on the situation that eval-case is used
+;; 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
+   (lambda (exp env)
+     (define (toplevel-env? env)
+       (or (not (pair? env)) (not (pair? (car env)))))
+     (define (syntax)
+       (error "syntax error in eval-case"))
+     (let loop ((clauses (cdr exp)))
+       (cond
+	((null? clauses)
+	 #f)
+	((not (list? (car clauses)))
+	 (syntax))
+	((eq? 'else (caar clauses))
+	 (or (null? (cdr clauses))
+	     (syntax))
+	 (cons 'begin (cdar clauses)))
+	((not (list? (caar clauses)))
+	 (syntax))
+	((and (toplevel-env? env)
+	      (memq 'load-toplevel (caar clauses)))
+	 (cons 'begin (cdar clauses)))
+	(else
+	 (loop (cdr clauses))))))))
 
 
-;;; {Deprecated stuff}
 
-(begin-deprecated
- (primitive-load-path "ice-9/deprecated.scm"))
+;; 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
+;;;
+
+(define macro-table (make-weak-key-hash-table 61))
+(define xformer-table (make-weak-key-hash-table 61))
+
+(define (defmacro? m)  (hashq-ref macro-table m))
+(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
+(define (defmacro-transformer m) (hashq-ref xformer-table m))
+(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
+
+(define defmacro:transformer
+  (lambda (f)
+    (let* ((xform (lambda (exp env)
+		    (copy-tree (apply f (cdr exp)))))
+	   (a (procedure->memoizing-macro xform)))
+      (assert-defmacro?! a)
+      (set-defmacro-transformer! a f)
+      a)))
+
+
+(define defmacro
+  (let ((defmacro-transformer
+	  (lambda (name parms . body)
+	    (let ((transformer `(lambda ,parms ,@body)))
+	      `(eval-case
+                ((load-toplevel compile-toplevel)
+                 (define ,name (defmacro:transformer ,transformer)))
+		(else
+		 (error "defmacro can only be used at the top level")))))))
+    (defmacro:transformer defmacro-transformer)))
+
+
+;; XXX - should the definition of the car really be looked up in the
+;; current module?
+
+(define (macroexpand-1 e)
+  (cond
+   ((pair? e) (let* ((a (car e))
+		     (val (and (symbol? a) (local-ref (list a)))))
+		(if (defmacro? val)
+		    (apply (defmacro-transformer val) (cdr e))
+		    e)))
+   (#t e)))
+
+(define (macroexpand e)
+  (cond
+   ((pair? e) (let* ((a (car e))
+		     (val (and (symbol? a) (local-ref (list a)))))
+		(if (defmacro? val)
+		    (macroexpand (apply (defmacro-transformer val) (cdr e)))
+		    e)))
+   (#t e)))
+
+(provide 'defmacro)
 
 
 
-;;; {Simple Debugging Tools}
-;;
+;;; {Deprecation}
+;;;
+;;; Depends on: defmacro
+;;;
 
+(defmacro begin-deprecated forms
+  (if (include-deprecated-features)
+      `(begin ,@forms)
+      (begin)))
+
+
+
+;;; {R4RS compliance}
+;;;
+
+(primitive-load-path "ice-9/r4rs")
+
+
+
+;;; {Simple Debugging Tools}
+;;;
 
 ;; peek takes any number of arguments, writes them to the
 ;; current ouput port, and returns the last argument.
@@ -111,12 +243,11 @@
       (car (last-pair stuff)))))
 
 
+
 ;;; {Trivial Functions}
 ;;;
 
 (define (identity x) x)
-(define (1+ n) (+ n 1))
-(define (1- n) (+ n -1))
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 
@@ -134,6 +265,24 @@
 
 (define (apply-to-args args fn) (apply fn args))
 
+(defmacro false-if-exception (expr)
+  `(catch #t (lambda () ,expr)
+	  (lambda args #f)))
+
+
+
+;;; {General Properties}
+;;;
+
+;; This is a more modern interface to properties.  It will replace all
+;; other property-like things eventually.
+
+(define (make-object-property)
+  (let ((prop (primitive-make-property #f)))
+    (make-procedure-with-setter
+     (lambda (obj) (primitive-property-ref prop obj))
+     (lambda (obj val) (primitive-property-set! prop obj val)))))
+
 
 
 ;;; {Symbol Properties}
@@ -154,37 +303,20 @@
     (if pair
 	(symbol-pset! sym (delq! pair (symbol-pref sym))))))
 
-;;; {General Properties}
-;;;
-
-;; This is a more modern interface to properties.  It will replace all
-;; other property-like things eventually.
-
-(define (make-object-property)
-  (let ((prop (primitive-make-property #f)))
-    (make-procedure-with-setter
-     (lambda (obj) (primitive-property-ref prop obj))
-     (lambda (obj val) (primitive-property-set! prop obj val)))))
-
 
 
 ;;; {Arrays}
 ;;;
 
-(if (provided? 'array)
-    (primitive-load-path "ice-9/arrays.scm"))
+(define (array-shape a)
+  (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+       (array-dimensions a)))
 
 
+
 ;;; {Keywords}
 ;;;
 
-(define (symbol->keyword symbol)
-  (make-keyword-from-dash-symbol (symbol-append '- symbol)))
-
-(define (keyword->symbol kw)
-  (let ((sym (symbol->string (keyword-dash-symbol kw))))
-    (string->symbol (substring sym 1 (string-length sym)))))
-
 (define (kw-arg-ref args kw)
   (let ((rem (member kw args)))
     (and rem (pair? (cdr rem)) (cadr rem))))
@@ -192,26 +324,13 @@
 
 
 ;;; {Structs}
+;;;
 
 (define (struct-layout s)
   (struct-ref (struct-vtable s) vtable-index-layout))
 
 
 
-;;; 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 (procedure-property closure 'module))))
-
-
 ;;; {Records}
 ;;;
 
@@ -287,35 +406,41 @@
 
 (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-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"
+		 (list (record-type-name rtd) obj)
+		 #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)
-		   (and (eq? ',rtd (record-type-descriptor 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)
-		   (and (eq? ',rtd (record-type-descriptor 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))))
@@ -328,12 +453,14 @@
 (provide 'record)
 
 
+
 ;;; {Booleans}
 ;;;
 
 (define (->bool x) (not (not x)))
 
 
+
 ;;; {Symbols}
 ;;;
 
@@ -347,6 +474,7 @@
   (string->symbol (apply string args)))
 
 
+
 ;;; {Lists}
 ;;;
 
@@ -358,15 +486,8 @@
 	     n
 	     (loop (+ n 1) (cdr l))))))
 
-(define (make-list n . init)
-  (if (pair? init) (set! init (car init)))
-  (let loop ((answer '())
-	     (n n))
-    (if (<= n 0)
-	answer
-	(loop (cons init answer) (- n 1)))))
-
 
+
 ;;; {and-map and or-map}
 ;;;
 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
@@ -402,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
@@ -433,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)
@@ -444,6 +562,7 @@
       #f))
 
 
+
 ;;; {Error Handling}
 ;;;
 
@@ -582,6 +701,7 @@
   (putenv name))
 
 
+
 ;;; {Load Paths}
 ;;;
 
@@ -602,10 +722,13 @@
 		   file)))
 
 
+
 ;;; {Help for scm_shell}
+;;;
 ;;; The argument-processing code used by Guile-based shells generates
 ;;; Scheme code based on the argument list.  This page contains help
 ;;; functions for the code it generates.
+;;;
 
 (define (command-line) (program-arguments))
 
@@ -626,7 +749,17 @@
 	(primitive-load init-file))))
 
 
+
+;;; {The interpreter stack}
+;;;
+
+(defmacro start-stack (tag exp)
+  `(%start-stack ,tag (lambda () ,exp)))
+
+
+
 ;;; {Loading by paths}
+;;;
 
 ;;; Load a Scheme source file named NAME, searching for it in the
 ;;; directories listed in %load-path, and applying each of the file
@@ -637,6 +770,7 @@
 
 
 
+
 ;;; {Transcendental Functions}
 ;;;
 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
@@ -644,28 +778,11 @@
 ;;; See the file `COPYING' for terms applying to this program.
 ;;;
 
-(define (exp z)
-  (if (real? z) ($exp z)
-      (make-polar ($exp (real-part z)) (imag-part z))))
-
-(define (log z)
-  (if (and (real? z) (>= z 0))
-      ($log z)
-      (make-rectangular ($log (magnitude z)) (angle z))))
-
-(define (sqrt z)
-  (if (real? z)
-      (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
-          ($sqrt z))
-      (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
-
 (define expt
   (let ((integer-expt integer-expt))
     (lambda (z1 z2)
-      (cond ((integer? z2)
-	     (if (negative? z2)
-		 (/ 1 (integer-expt z1 (- z2)))
-		 (integer-expt z1 z2)))
+      (cond ((and (exact? z2) (integer? z2))
+	     (integer-expt z1 z2))
 	    ((and (real? z2) (real? z1) (>= z1 0))
 	     ($expt z1 z2))
 	    (else
@@ -735,14 +852,10 @@
 	  (/ (log (/ (- +i z) (+ +i z))) +2i))
       ($atan2 z (car y))))
 
-(define (log10 arg)
-  (/ (log arg) (log 10)))
-
 
 
 ;;; {Reader Extensions}
 ;;;
-
 ;;; Reader code for various "#c" forms.
 ;;;
 
@@ -759,6 +872,7 @@
                          "#. read expansion found and read-eval? is #f."))))
 
 
+
 ;;; {Command Line Options}
 ;;;
 
@@ -976,18 +1090,20 @@
 ;;;   'module, 'directory, 'interface, 'custom-interface.  If no explicit kind
 ;;;   is set, it defaults to 'module.
 ;;;
-;;; - duplicates-handlers
+;;; - 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.
 ;;;
-;;; - duplicates-interface
+;;; - observers: a list of procedures that get called when the module is
+;;;   modified.
 ;;;
-;;; - observers
-;;;
-;;; - 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
@@ -1015,7 +1131,10 @@
 ;;;
 
 
+
 ;;; {Printing Modules}
+;;;
+
 ;; This is how modules are printed.  You can re-define it.
 ;; (Redefining is actually more complicated than simply redefining
 ;; %print-module because that would only change the binding and not
@@ -1042,13 +1161,14 @@
 ;; is a (CLOSURE module symbol) which, as a last resort, can provide
 ;; bindings that would otherwise not be found locally in the module.
 ;;
-;; NOTE: If you change here, you also need to change libguile/modules.h.
+;; NOTE: If you change anything here, you also need to change
+;; libguile/modules.h.
 ;;
 (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
@@ -1064,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))
 
@@ -1081,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
@@ -1114,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)
@@ -1135,6 +1255,7 @@
       (set-procedure-property! closure 'module module))))
 
 
+
 ;;; {Observer protocol}
 ;;;
 
@@ -1142,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))
@@ -1184,9 +1313,14 @@
 
 (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)))
 
 
+
 ;;; {Module Searching in General}
 ;;;
 ;;; We sometimes want to look for properties of a symbol
@@ -1307,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}
 ;;;
@@ -1366,10 +1482,9 @@
 
 
 
+
 ;;; {Adding Variables to Modules}
 ;;;
-;;;
-
 
 ;; module-make-local-var! module symbol
 ;;
@@ -1387,12 +1502,11 @@
 	       ;; the standard eval closure defines a binding
 	       (module-modified m)
 	       b)))
-      (and (module-binder m)
-	   ((module-binder m) m v #t))
-      (begin
-	(let ((answer (make-undefined-variable)))
-	  (module-add! m v answer)
-	  answer))))
+
+      ;; 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
 ;;
@@ -1436,7 +1550,7 @@
   (hash-for-each proc (module-obarray module)))
 
 (define (module-map proc module)
-  (hash-map proc (module-obarray module)))
+  (hash-map->list proc (module-obarray module)))
 
 
 
@@ -1470,6 +1584,7 @@
 
 
 
+
 ;;; {Module-based Loading}
 ;;;
 
@@ -1488,22 +1603,26 @@
 
 (define basic-load load)
 
-(define (load-module filename)
+(define (load-module filename . reader)
   (save-module-excursion
    (lambda ()
      (let ((oldname (and (current-load-port)
 			 (port-filename (current-load-port)))))
-       (basic-load (if (and oldname
-			    (> (string-length filename) 0)
-			    (not (char=? (string-ref filename 0) #\/))
-			    (not (string=? (dirname oldname) ".")))
-		       (string-append (dirname oldname) "/" filename)
-		       filename))))))
+       (apply basic-load
+	      (if (and oldname
+		       (> (string-length filename) 0)
+		       (not (char=? (string-ref filename 0) #\/))
+		       (not (string=? (dirname oldname) ".")))
+		  (string-append (dirname oldname) "/" filename)
+		  filename)
+	      reader)))))
 
 
 
+
 ;;; {MODULE-REF -- exported}
-;;
+;;;
+
 ;; Returns the value of a variable called NAME in MODULE or any of its
 ;; used modules.  If there is no such variable, then if the optional third
 ;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
@@ -1556,51 +1675,34 @@
 ;; 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))
 
 
+
 ;;; {Recursive Namespaces}
 ;;;
-;;;
 ;;; A hierarchical namespace emerges if we consider some module to be
 ;;; root, and variables bound to modules as nested namespaces.
 ;;;
@@ -1670,12 +1772,13 @@
 
 
 
-;;; {The (app) module}
+
+;;; {The (%app) module}
 ;;;
 ;;; The root of conventionally named objects not directly in the top level.
 ;;;
-;;; (app modules)
-;;; (app modules guile)
+;;; (%app modules)
+;;; (%app modules guile)
 ;;;
 ;;; The directory of all modules and the standard root module.
 ;;;
@@ -1720,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 (local-ref 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.
@@ -1752,17 +1859,20 @@
 (define process-define-module #f)
 (define process-use-modules #f)
 (define module-export! #f)
+(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 app (make-module 31))
-(local-define '(app modules) (make-module 31))
-(local-define '(app modules guile) the-root-module)
-
-;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
+;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
 
 (define (try-load-module name)
   (or (begin-deprecated (try-module-linked name))
@@ -1882,87 +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))
 
@@ -1971,7 +2092,10 @@
 ;; module.
 (define module-defined-hook (make-hook 1))
 
+
+
 ;;; {Autoload}
+;;;
 
 (define (make-autoload-interface module name bindings)
   (let ((b (lambda (a sym definep)
@@ -1979,18 +2103,42 @@
 		  (let ((i (module-public-interface (resolve-module name))))
 		    (if (not i)
 			(error "missing interface for module" name))
-		    ;; Replace autoload-interface with interface
-		    (set-car! (memq a (module-uses module)) i)
+		    (let ((autoload (memq a (module-uses module))))
+		      ;; Replace autoload-interface with actual interface if
+		      ;; that has not happened yet.
+		      (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))
 
 
+
 ;;; {Autoloading modules}
+;;;
 
 (define autoloads-in-progress '())
 
@@ -2015,18 +2163,27 @@
 	    (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)
-			    (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))))
 
 
-;;; Dynamic linking of modules
+
+;;; {Dynamic linking of modules}
+;;;
 
 (define autoloads-done '((guile . guile)))
 
@@ -2055,133 +2212,16 @@
 	(set! autoloads-done (delete! n autoloads-done))
 	(set! autoloads-in-progress (delete! n autoloads-in-progress)))))
 
-
-
-
-;; {EVAL-CASE}
-;;
-;; (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.
-
-(define eval-case
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (define (toplevel-env? env)
-       (or (not (pair? env)) (not (pair? (car env)))))
-     (define (syntax)
-       (error "syntax error in eval-case"))
-     (let loop ((clauses (cdr exp)))
-       (cond
-	((null? clauses)
-	 #f)
-	((not (list? (car clauses)))
-	 (syntax))
-	((eq? 'else (caar clauses))
-	 (or (null? (cdr clauses))
-	     (syntax))
-	 (cons 'begin (cdar clauses)))
-	((not (list? (caar clauses)))
-	 (syntax))
-	((and (toplevel-env? env)
-	      (memq 'load-toplevel (caar clauses)))
-	 (cons 'begin (cdar clauses)))
-	(else
-	 (loop (cdr clauses))))))))
-
-
-;;; {Macros}
-;;;
-
-(define (primitive-macro? m)
-  (and (macro? m)
-       (not (macro-transformer m))))
-
-;;; {Defmacros}
-;;;
-(define macro-table (make-weak-key-hash-table 61))
-(define xformer-table (make-weak-key-hash-table 61))
-
-(define (defmacro? m)  (hashq-ref macro-table m))
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
-
-(define defmacro:transformer
-  (lambda (f)
-    (let* ((xform (lambda (exp env)
-		    (copy-tree (apply f (cdr exp)))))
-	   (a (procedure->memoizing-macro xform)))
-      (assert-defmacro?! a)
-      (set-defmacro-transformer! a f)
-      a)))
-
-
-(define defmacro
-  (let ((defmacro-transformer
-	  (lambda (name parms . body)
-	    (let ((transformer `(lambda ,parms ,@body)))
-	      `(eval-case
-		((load-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?
-
-(define (macroexpand-1 e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (apply (defmacro-transformer val) (cdr e))
-		    e)))
-   (#t e)))
-
-(define (macroexpand e)
-  (cond
-   ((pair? e) (let* ((a (car e))
-		     (val (and (symbol? a) (local-ref (list a)))))
-		(if (defmacro? val)
-		    (macroexpand (apply (defmacro-transformer val) (cdr e)))
-		    e)))
-   (#t e)))
-
-(provide 'defmacro)
-
 
 
 ;;; {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)
@@ -2189,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
@@ -2205,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
@@ -2297,36 +2345,20 @@
 	     (catch #t
 
 		    (lambda ()
-		      (lazy-catch #t
-				  (lambda ()
-				    (call-with-unblocked-asyncs
-				     (lambda ()
-				       (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)))))
-
-				  ;; Use a closure here rather than
-				  ;; just `lazy-handler-dispatch' so
-				  ;; that lookup of
-				  ;; lazy-handler-dispatch's value is
-				  ;; deferred until a throw occurs.
-				  ;; This means that if code executed
-				  ;; in the REPL just above set!s
-				  ;; lazy-handler-dispatch, the new
-				  ;; value will be used to handle the
-				  ;; next throw from the REPL.
-				  (lambda args
-				    (apply lazy-handler-dispatch args))))
+		      (call-with-unblocked-asyncs
+		       (lambda ()
+			 (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)))))
 
 		    (lambda (key . args)
 		      (case key
@@ -2371,7 +2403,18 @@
 			   (cond ((= (length args) 4)
 				  (apply handle-system-error key args))
 				 (else
-				  (apply bad-throw key args))))))))))
+				  (apply bad-throw key args)))))))
+
+		    ;; Note that having just `lazy-handler-dispatch'
+		    ;; here is connected with the mechanism that
+		    ;; produces a nice backtrace upon error.  If, for
+		    ;; example, this is replaced with (lambda args
+		    ;; (apply lazy-handler-dispatch args)), the stack
+		    ;; cutting (in save-stack) goes wrong and ends up
+		    ;; saving no stack at all, so there is no
+		    ;; backtrace.
+		    lazy-handler-dispatch)))
+
 	(if next (loop next) status)))
     (set! set-batch-mode?! (lambda (arg)
 			     (cond (arg
@@ -2421,12 +2464,17 @@
   (let ((cep (current-error-port)))
     (cond ((not (stack? (fluid-ref the-last-stack))))
 	  ((memq 'backtrace (debug-options-interface))
-	   (run-hook before-backtrace-hook)
-	   (newline cep)
-	   (display "Backtrace:\n")
-	   (display-backtrace (fluid-ref the-last-stack) cep)
-	   (newline cep)
-	   (run-hook after-backtrace-hook)))
+	   (let ((highlights (if (or (eq? key 'wrong-type-arg)
+				     (eq? key 'out-of-range))
+				 (list-ref args 3)
+				 '())))
+	     (run-hook before-backtrace-hook)
+	     (newline cep)
+	     (display "Backtrace:\n")
+	     (display-backtrace (fluid-ref the-last-stack) cep
+				#f #f highlights)
+	     (newline cep)
+	     (run-hook after-backtrace-hook))))
     (run-hook before-error-hook)
     (apply display-error (fluid-ref the-last-stack) cep args)
     (run-hook after-error-hook)
@@ -2476,10 +2524,10 @@
 ;;; the readline library.
 (define repl-reader
   (lambda (prompt)
-    (display prompt)
+    (display (if (string? prompt) prompt (prompt)))
     (force-output)
     (run-hook before-read-hook)
-    (read (current-input-port))))
+    ((or (fluid-ref current-reader) read) (current-input-port))))
 
 (define (scm-style-repl)
 
@@ -2598,7 +2646,9 @@
 
 
 
+
 ;;; {IOTA functions: generating lists of numbers}
+;;;
 
 (define (iota n)
   (let loop ((count (1- n)) (result '()))
@@ -2606,17 +2656,22 @@
         (loop (1- count) (cons count result)))))
 
 
+
 ;;; {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 is a convenience wrapper for the builtin procedure
 ;; `with-fluids*'.  The syntax is just like `let':
@@ -2642,6 +2697,10 @@
 ;; coaxing
 ;;
 
+(define (primitive-macro? m)
+  (and (macro? m)
+       (not (macro-transformer m))))
+
 (defmacro define-macro (first . rest)
   (let ((name (if (symbol? first) first (car first)))
 	(transformer
@@ -2649,23 +2708,13 @@
 	     (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}
 ;;;
@@ -2678,28 +2727,44 @@
 ;; `while' even when recursing.  `while-helper' is an easy way to keep the
 ;; `key' binding away from the cond and body code.
 ;;
+;; FIXME: This is supposed to have an `unquote' on the `do' the same used
+;; for lambda and not, so as to protect against any user rebinding of that
+;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
+;;
+;;     (use-modules (ice-9 syncase))
+;;     (while #f)
+;;     => ERROR: invalid syntax ()
+;;
+;; 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))))))
 
 
 
+
 ;;; {Module System Macros}
 ;;;
 
 ;; 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)
@@ -2764,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)
@@ -2789,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)))
@@ -2800,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))))
@@ -2830,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)
@@ -2845,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
@@ -2884,7 +2949,7 @@
 
 (defmacro export names
   `(eval-case
-    ((load-toplevel)
+    ((load-toplevel compile-toplevel)
      (call-with-deferred-observers
       (lambda ()
 	(module-export! (current-module) ',names))))
@@ -2893,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))))
@@ -2918,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)
@@ -2934,6 +3000,7 @@
     var))
 
 
+
 ;;; {Parameters}
 ;;;
 
@@ -2952,6 +3019,7 @@
 	(make fluid converter)))))
 
 
+
 ;;; {Handling of duplicate imported bindings}
 ;;;
 
@@ -2987,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
@@ -3009,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)
@@ -3058,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.}
@@ -3138,13 +3155,23 @@
 ;;;
 ;;; Currently, the following feature identifiers are supported:
 ;;;
-;;;   guile r5rs srfi-0
+;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
 ;;;
 ;;; Remember to update the features list when adding more SRFIs.
+;;;
 
 (define %cond-expand-features
   ;; Adjust the above comment when changing this.
-  '(guile r5rs srfi-0))
+  '(guile
+    r5rs
+    srfi-0   ;; cond-expand itself
+    srfi-4   ;; homogenous numeric vectors
+    srfi-6   ;; open-input-string etc, in the guile core
+    srfi-13  ;; string library
+    srfi-14  ;; character sets
+    srfi-55  ;; require-extension
+    srfi-61  ;; general cond clause
+    ))
 
 ;; This table maps module public interfaces to the list of features.
 ;;
@@ -3228,17 +3255,51 @@
 ;; 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)))
+
+
+
+;;; srfi-55: require-extension
+;;;
+
+(define-macro (require-extension extension-spec)
+  ;; This macro only handles the srfi extension, which, at present, is
+  ;; the only one defined by the standard.
+  (if (not (pair? extension-spec))
+      (scm-error 'wrong-type-arg "require-extension"
+                 "Not an extension: ~S" (list extension-spec) #f))
+  (let ((extension (car extension-spec))
+        (extension-args (cdr extension-spec)))
+    (case extension
+      ((srfi)
+       (let ((use-list '()))
+         (for-each
+          (lambda (i)
+            (if (not (integer? i))
+                (scm-error 'wrong-type-arg "require-extension"
+                           "Invalid srfi name: ~S" (list i) #f))
+            (let ((srfi-sym (string->symbol
+                             (string-append "srfi-" (number->string i)))))
+              (if (not (memq srfi-sym %cond-expand-features))
+                  (set! use-list (cons `(use-modules (srfi ,srfi-sym))
+                                       use-list)))))
+          extension-args)
+         (if (pair? use-list)
+             ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
+             `(begin ,@(reverse! use-list)))))
+      (else
+       (scm-error
+        'wrong-type-arg "require-extension"
+        "Not a recognized extension type: ~S" (list extension) #f)))))
 
 
 
 ;;; {Load emacs interface support if emacs option is given.}
+;;;
 
 (define (named-module-use! user usee)
   (module-use! (resolve-module user) (resolve-interface usee)))
@@ -3266,29 +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 '(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
 
@@ -3313,7 +3382,7 @@
 
 	  ;; the protected thunk.
 	  (lambda ()
-	    (let ((status (scm-style-repl)))
+            (let ((status (start-repl 'scheme)))
 	      (run-hook exit-hook)
 	      status))
 
@@ -3329,19 +3398,28 @@
 				  (cdr old-handler))))
 		 signals old-handlers))))))
 
-(defmacro false-if-exception (expr)
-  `(,catch #t (,lambda () ,expr)
-	   (,lambda args #f)))
-
 ;;; This hook is run at the very end of an interactive session.
 ;;;
 (define exit-hook (make-hook))
 
 
-(append! %load-path (list "."))
 
-;; Place the user in the guile-user module.
-;;
+;;; {Deprecated stuff}
+;;;
+
+(begin-deprecated
+ (define (feature? sym)
+   (issue-deprecation-warning
+    "`feature?' is deprecated.  Use `provided?' instead.")
+   (provided? sym)))
+
+(begin-deprecated
+ (primitive-load-path "ice-9/deprecated"))
+
+
+
+;;; Place the user in the guile-user module.
+;;;
 
 (define-module (guile-user))