X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/5f236208d0d864546e59afa0f5a11c9b3ba14b10..d8e1bce4fc8d23a94e3a5f8b4248adbb1e5555be:/module/ice-9/boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 21e3506cd..9c286bba3 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -40,6 +40,164 @@
 (eval-when (compile)
   (set-current-module (resolve-module '(guile))))
 
+
+
+;;; {Error handling}
+;;;
+
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
+
+(define make-prompt-tag
+  (lambda* (#:optional (stem "prompt"))
+    (gensym stem)))
+
+(define default-prompt-tag
+  ;; not sure if we should expose this to the user as a fluid
+  (let ((%default-prompt-tag (make-prompt-tag)))
+    (lambda ()
+      %default-prompt-tag)))
+
+(define (call-with-prompt tag thunk handler)
+  (@prompt tag (thunk) handler))
+(define (abort-to-prompt tag . args)
+  (@abort tag args))
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(let ()
+  ;; Ideally we'd like to be able to give these default values for all threads,
+  ;; even threads not created by Guile; but alack, that does not currently seem
+  ;; possible. So wrap the getters in thunks.
+  (define %running-exception-handlers (make-fluid))
+  (define %exception-handler (make-fluid))
+
+  (define (running-exception-handlers)
+    (or (fluid-ref %running-exception-handlers)
+        (begin
+          (fluid-set! %running-exception-handlers '())
+          '())))
+  (define (exception-handler)
+    (or (fluid-ref %exception-handler)
+        (begin
+          (fluid-set! %exception-handler default-exception-handler)
+          default-exception-handler)))
+
+  (define (default-exception-handler k . args)
+    (cond
+     ((eq? k 'quit)
+      (primitive-exit (cond
+                       ((not (pair? args)) 0)
+                       ((integer? (car args)) (car args))
+                       ((not (car args)) 1)
+                       (else 0))))
+     (else
+      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
+      (primitive-exit 1))))
+
+  (define (default-throw-handler prompt-tag catch-k)
+    (let ((prev (exception-handler)))
+      (lambda (thrown-k . args)
+        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+            (apply abort-to-prompt prompt-tag thrown-k args)
+            (apply prev thrown-k args)))))
+
+  (define (custom-throw-handler prompt-tag catch-k pre)
+    (let ((prev (exception-handler)))
+      (lambda (thrown-k . args)
+        (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
+            (let ((running (running-exception-handlers)))
+              (with-fluids ((%running-exception-handlers (cons pre running)))
+                (if (not (memq pre running))
+                    (apply pre thrown-k args))
+                ;; fall through
+                (if prompt-tag
+                    (apply abort-to-prompt prompt-tag thrown-k args)
+                    (apply prev thrown-k args))))
+            (apply prev thrown-k args)))))
+
+  (define! 'catch
+    (lambda* (k thunk handler #:optional pre-unwind-handler)
+      "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}.  If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments.  If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}.  @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}.  It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler.  If it exits
+non-locally, that exit determines the continuation."
+      (if (not (or (symbol? k) (eqv? k #t)))
+          (scm-error "catch" 'wrong-type-arg
+                     "Wrong type argument in position ~a: ~a"
+                     (list 1 k) (list k)))
+      (let ((tag (make-prompt-tag "catch")))
+        (call-with-prompt
+         tag
+         (lambda ()
+           (with-fluids
+               ((%exception-handler
+                 (if pre-unwind-handler
+                     (custom-throw-handler tag k pre-unwind-handler)
+                     (default-throw-handler tag k))))
+             (thunk)))
+         (lambda (cont k . args)
+           (apply handler k args))))))
+
+  (define! 'with-throw-handler
+    (lambda (k thunk pre-unwind-handler)
+      "Add @var{handler} to the dynamic context as a throw handler
+for key @var{key}, then invoke @var{thunk}."
+      (if (not (or (symbol? k) (eqv? k #t)))
+          (scm-error "with-throw-handler" 'wrong-type-arg
+                     "Wrong type argument in position ~a: ~a"
+                     (list 1 k) (list k)))
+      (with-fluids ((%exception-handler
+                     (custom-throw-handler #f k pre-unwind-handler)))
+        (thunk))))
+
+  (define! 'throw
+    (lambda (key . args)
+      "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+      (if (not (symbol? key))
+          ((exception-handler) 'wrong-type-arg "throw"
+           "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
+          (apply (exception-handler) key args)))))
+
+
+
+
 ;;; {R4RS compliance}
 ;;;
 
@@ -55,8 +213,8 @@
 ;; It is handy to wrap around an expression to look at
 ;; a value each time is evaluated, e.g.:
 ;;
-;;	(+ 10 (troublesome-fn))
-;;	=> (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;;      (+ 10 (troublesome-fn))
+;;      => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
 ;;
 
 (define (peek . stuff)
@@ -68,6 +226,7 @@
 
 (define pk peek)
 
+
 (define (warn . stuff)
   (with-output-to-port (current-error-port)
     (lambda ()
@@ -109,11 +268,11 @@
 ;;
 (define (and-map f lst)
   (let loop ((result #t)
-	     (l lst))
+             (l lst))
     (and result
-	 (or (and (null? l)
-		  result)
-	     (loop (f (car l)) (cdr l))))))
+         (or (and (null? l)
+                  result)
+             (loop (f (car l)) (cdr l))))))
 
 ;; or-map f l
 ;;
@@ -122,10 +281,10 @@
 ;;
 (define (or-map f lst)
   (let loop ((result #f)
-	     (l lst))
+             (l lst))
     (or result
-	(and (not (null? l))
-	     (loop (f (car l)) (cdr l))))))
+        (and (not (null? l))
+             (loop (f (car l)) (cdr l))))))
 
 
 
@@ -135,31 +294,25 @@
 
 ;; 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))))
+(define string-any
+  (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
     (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))))
+             (> 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))))
+(define string-every
+  (lambda* (char_pred s #:optional (start 0) (end (string-length s)))
     (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))))
+             (> 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
 ;;
@@ -193,22 +346,20 @@
 (define syntax-violation #f)
 (define datum->syntax #f)
 (define syntax->datum #f)
+(define syntax-source #f)
 (define identifier? #f)
 (define generate-temporaries #f)
 (define bound-identifier=? #f)
 (define free-identifier=? #f)
-(define sc-expand #f)
 
-;; $sc-expand is an implementation detail of psyntax. It is used by
+;; $sc-dispatch is an implementation detail of psyntax. It is used by
 ;; expanded macros, to dispatch an input against a set of patterns.
 (define $sc-dispatch #f)
 
 ;; Load it up!
 (primitive-load-path "ice-9/psyntax-pp")
-
-;; %pre-modules-transformer is the Scheme expander from now until the
-;; module system has booted up.
-(define %pre-modules-transformer sc-expand)
+;; The binding for `macroexpand' has now been overridden, making psyntax the
+;; expander now.
 
 (define-syntax and
   (syntax-rules ()
@@ -308,36 +459,14 @@
   (syntax-rules ()
     ((_ exp) (make-promise (lambda () exp)))))
 
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
+(include-from-path "ice-9/quasisyntax")
+
+(define-syntax current-source-location
   (lambda (x)
-    (define (bound-member id ids)
-      (cond ((null? ids) #f)
-            ((bound-identifier=? id (car ids)) #t)
-            ((bound-member (car ids) (cdr ids)))))
-    
     (syntax-case x ()
-      ((_ () b0 b1 ...)
-       #'(let () b0 b1 ...))
-      ((_ ((id val) ...) b0 b1 ...)
-       (and-map identifier? #'(id ...))
-       (if (let lp ((ids #'(id ...)))
-             (cond ((null? ids) #f)
-                   ((bound-member (car ids) (cdr ids)) #t)
-                   (else (lp (cdr ids)))))
-           (syntax-violation '@bind "duplicate bound identifier" x)
-           (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
-                         ((v ...) (generate-temporaries #'(id ...))))
-             #'(let ((old-v id) ...
-                     (v val) ...)
-                 (dynamic-wind
-                   (lambda ()
-                     (set! id v) ...)
-                   (lambda () b0 b1 ...)
-                   (lambda ()
-                     (set! id old-v) ...)))))))))
+      ((_)
+       (with-syntax ((s (datum->syntax x (syntax-source x))))
+         #''s)))))
 
 
 
@@ -350,31 +479,32 @@
     "Define a defmacro."
     (syntax-case x ()
       ((_ (macro . args) doc body1 body ...)
-       (string? (syntax->datum (syntax doc)))
-       (syntax (define-macro macro doc (lambda args body1 body ...))))
+       (string? (syntax->datum #'doc))
+       #'(define-macro macro doc (lambda args body1 body ...)))
       ((_ (macro . args) body ...)
-       (syntax (define-macro macro #f (lambda args body ...))))
+       #'(define-macro macro #f (lambda args body ...)))
       ((_ macro doc transformer)
-       (or (string? (syntax->datum (syntax doc)))
-           (not (syntax->datum (syntax doc))))
-       (syntax
-        (define-syntax macro
-          (lambda (y)
-            doc
-            (syntax-case y ()
-              ((_ . args)
-               (let ((v (syntax->datum (syntax args))))
-                 (datum->syntax y (apply transformer v))))))))))))
+       (or (string? (syntax->datum #'doc))
+           (not (syntax->datum #'doc)))
+       #'(define-syntax macro
+           (lambda (y)
+             doc
+             #((macro-type . defmacro)
+               (defmacro-args args))
+             (syntax-case y ()
+               ((_ . args)
+                (let ((v (syntax->datum #'args)))
+                  (datum->syntax y (apply transformer v)))))))))))
 
 (define-syntax defmacro
   (lambda (x)
     "Define a defmacro, with the old lispy defun syntax."
     (syntax-case x ()
       ((_ macro args doc body1 body ...)
-       (string? (syntax->datum (syntax doc)))
-       (syntax (define-macro macro doc (lambda args body1 body ...))))
+       (string? (syntax->datum #'doc))
+       #'(define-macro macro doc (lambda args body1 body ...)))
       ((_ macro args body ...)
-       (syntax (define-macro macro #f (lambda args body ...)))))))
+       #'(define-macro macro #f (lambda args body ...))))))
 
 (provide 'defmacro)
 
@@ -406,9 +536,9 @@
 ;;; perform binding in many circumstances when the "let" family of
 ;;; of forms don't cut it.  E.g.:
 ;;;
-;;;	(apply-to-args (return-3d-mouse-coords)
-;;;	  (lambda (x y z)
-;;;		...))
+;;;     (apply-to-args (return-3d-mouse-coords)
+;;;       (lambda (x y z)
+;;;             ...))
 ;;;
 
 (define (apply-to-args args fn) (apply fn args))
@@ -417,8 +547,8 @@
   `(catch #t
      (lambda ()
        ;; avoid saving backtraces inside false-if-exception
-       (with-fluid* the-last-stack (fluid-ref the-last-stack)
-         (lambda () ,expr)))
+       (with-fluids ((the-last-stack (fluid-ref the-last-stack)))
+         ,expr))
      (lambda args #f)))
 
 
@@ -447,13 +577,13 @@
 (define (set-symbol-property! sym prop val)
   (let ((pair (assoc prop (symbol-pref sym))))
     (if pair
-	(set-cdr! pair val)
-	(symbol-pset! sym (acons prop val (symbol-pref sym))))))
+        (set-cdr! pair val)
+        (symbol-pset! sym (acons prop val (symbol-pref sym))))))
 
 (define (symbol-property-remove! sym prop)
   (let ((pair (assoc prop (symbol-pref sym))))
     (if pair
-	(symbol-pset! sym (delq! pair (symbol-pref sym))))))
+        (symbol-pset! sym (delq! pair (symbol-pref sym))))))
 
 
 
@@ -503,48 +633,88 @@
       (port-with-print-state new-port (get-print-state old-port))
       new-port))
 
-;; 0: type-name, 1: fields
+;; 0: type-name, 1: fields, 2: constructor
 (define record-type-vtable
-  (make-vtable-vtable "prpr" 0
-		      (lambda (s p)
-			(cond ((eq? s record-type-vtable)
-			       (display "#<record-type-vtable>" p))
-			      (else
-			       (display "#<record-type " p)
-			       (display (record-type-name s) p)
-			       (display ">" p))))))
+  ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
+  ;; that we need to expose the bare vtable-vtable to Scheme.
+  (make-vtable-vtable "prprpw" 0
+                      (lambda (s p)
+                        (cond ((eq? s record-type-vtable)
+                               (display "#<record-type-vtable>" p))
+                              (else
+                               (display "#<record-type " p)
+                               (display (record-type-name s) p)
+                               (display ">" p))))))
 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
 
-(define (make-record-type type-name fields . opt)
-  (let ((printer-fn (and (pair? opt) (car opt))))
-    (let ((struct (make-struct record-type-vtable 0
-			       (make-struct-layout
-				(apply string-append
-				       (map (lambda (f) "pw") fields)))
-			       (or printer-fn
-				   (lambda (s p)
-				     (display "#<" p)
-				     (display type-name p)
-				     (let loop ((fields fields)
-						(off 0))
-				       (cond
-					((not (null? fields))
-					 (display " " p)
-					 (display (car fields) p)
-					 (display ": " p)
-					 (display (struct-ref s off) p)
-					 (loop (cdr fields) (+ 1 off)))))
-				     (display ">" p)))
-			       type-name
-			       (copy-tree fields))))
-      ;; Temporary solution: Associate a name to the record type descriptor
-      ;; so that the object system can create a wrapper class for it.
-      (set-struct-vtable-name! struct (if (symbol? type-name)
-					  type-name
-					  (string->symbol type-name)))
-      struct)))
+(define* (make-record-type type-name fields #:optional printer)
+  ;; Pre-generate constructors for nfields < 20.
+  (define-syntax make-constructor
+    (lambda (x)
+      (define *max-static-argument-count* 20)
+      (define (make-formals n)
+        (let lp ((i 0))
+          (if (< i n)
+              (cons (datum->syntax
+                     x 
+                     (string->symbol
+                      (string (integer->char (+ (char->integer #\a) i)))))
+                    (lp (1+ i)))
+              '())))
+      (syntax-case x ()
+        ((_ rtd exp) (not (identifier? #'exp))
+         #'(let ((n exp))
+             (make-constructor rtd n)))
+        ((_ rtd nfields)
+         #`(case nfields
+             #,@(let lp ((n 0))
+                  (if (< n *max-static-argument-count*)
+                      (cons (with-syntax (((formal ...) (make-formals n))
+                                          (n n))
+                              #'((n)
+                                 (lambda (formal ...)
+                                   (make-struct rtd 0 formal ...))))
+                            (lp (1+ n)))
+                      '()))
+             (else
+              (lambda args
+                (if (= (length args) nfields)
+                    (apply make-struct rtd 0 args)
+                    (scm-error 'wrong-number-of-args
+                               (format #f "make-~a" type-name)
+                               "Wrong number of arguments" '() #f)))))))))
+
+  (define (default-record-printer s p)
+    (display "#<" p)
+    (display (record-type-name (record-type-descriptor s)) p)
+    (let loop ((fields (record-type-fields (record-type-descriptor s)))
+               (off 0))
+      (cond
+       ((not (null? fields))
+        (display " " p)
+        (display (car fields) p)
+        (display ": " p)
+        (display (struct-ref s off) p)
+        (loop (cdr fields) (+ 1 off)))))
+    (display ">" p))
+
+  (let ((rtd (make-struct record-type-vtable 0
+                          (make-struct-layout
+                           (apply string-append
+                                  (map (lambda (f) "pw") fields)))
+                          (or printer default-record-printer)
+                          type-name
+                          (copy-tree fields))))
+    (struct-set! rtd (+ vtable-offset-user 2)
+                 (make-constructor rtd (length fields)))
+    ;; Temporary solution: Associate a name to the record type descriptor
+    ;; so that the object system can create a wrapper class for it.
+    (set-struct-vtable-name! rtd (if (symbol? type-name)
+                                     type-name
+                                     (string->symbol type-name)))
+    rtd))
 
 (define (record-type-name obj)
   (if (record-type? obj)
@@ -556,15 +726,16 @@
       (struct-ref obj (+ 1 vtable-offset-user))
       (error 'not-a-record-type obj)))
 
-(define (record-constructor rtd . opt)
-  (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
-    (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-constructor rtd #:optional field-names)
+  (if (not field-names)
+      (struct-ref rtd (+ 2 vtable-offset-user))
+      (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)))))
@@ -572,14 +743,14 @@
 (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)))
+                 "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)))
     (if (not pos)
-	(error 'no-such-field field-name))
+        (error 'no-such-field field-name))
     (lambda (obj)
       (if (eq? (struct-vtable obj) rtd)
           (struct-ref obj pos)
@@ -588,7 +759,7 @@
 (define (record-modifier rtd field-name)
   (let ((pos (list-index (record-type-fields rtd) field-name)))
     (if (not pos)
-	(error 'no-such-field field-name))
+        (error 'no-such-field field-name))
     (lambda (obj val)
       (if (eq? (struct-vtable obj) rtd)
           (struct-set! obj pos val)
@@ -632,11 +803,11 @@
 
 (define (list-index l k)
   (let loop ((n 0)
-	     (l l))
+             (l l))
     (and (not (null? l))
-	 (if (eq? (car l) k)
-	     n
-	     (loop (+ n 1) (cdr l))))))
+         (if (eq? (car l) k)
+             n
+             (loop (+ n 1) (cdr l))))))
 
 
 
@@ -650,24 +821,24 @@
 (define file-exists?
   (if (provided? 'posix)
       (lambda (str)
-	(->bool (stat str #f)))
+        (->bool (stat str #f)))
       (lambda (str)
-	(let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
-			   (lambda args #f))))
-	  (if port (begin (close-port port) #t)
-	      #f)))))
+        (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+                           (lambda args #f))))
+          (if port (begin (close-port port) #t)
+              #f)))))
 
 (define file-is-directory?
   (if (provided? 'posix)
       (lambda (str)
-	(eq? (stat:type (stat str)) 'directory))
+        (eq? (stat:type (stat str)) 'directory))
       (lambda (str)
-	(let ((port (catch 'system-error
-			   (lambda () (open-file (string-append str "/.")
-						 OPEN_READ))
-			   (lambda args #f))))
-	  (if port (begin (close-port port) #t)
-	      #f)))))
+        (let ((port (catch 'system-error
+                           (lambda () (open-file (string-append str "/.")
+                                                 OPEN_READ))
+                           (lambda args #f))))
+          (if port (begin (close-port port) #t)
+              #f)))))
 
 (define (has-suffix? str suffix)
   (string-suffix? suffix str))
@@ -687,11 +858,11 @@
   (if (null? args)
       (scm-error 'misc-error #f "?" #f #f)
       (let loop ((msg "~A")
-		 (rest (cdr args)))
-	(if (not (null? rest))
-	    (loop (string-append msg " ~S")
-		  (cdr rest))
-	    (scm-error 'misc-error #f msg args #f)))))
+                 (rest (cdr args)))
+        (if (not (null? rest))
+            (loop (string-append msg " ~S")
+                  (cdr rest))
+            (scm-error 'misc-error #f msg args #f)))))
 
 ;; bad-throw is the hook that is called upon a throw to a an unhandled
 ;; key (unless the throw has four arguments, in which case
@@ -702,7 +873,7 @@
 (define (bad-throw key . args)
   (let ((default (symbol-property key 'throw-handler-default)))
     (or (and default (apply default key args))
-	(apply error "unhandled-exception:" key args))))
+        (apply error "unhandled-exception:" key args))))
 
 
 
@@ -737,42 +908,57 @@
 (define (tms:cstime obj) (vector-ref obj 4))
 
 (define file-position ftell)
-(define (file-set-position port offset . whence)
-  (let ((whence (if (eq? whence '()) SEEK_SET (car whence))))
-    (seek port offset whence)))
+(define* (file-set-position port offset #:optional (whence SEEK_SET))
+  (seek port offset whence))
 
 (define (move->fdes fd/port fd)
   (cond ((integer? fd/port)
-	 (dup->fdes fd/port fd)
-	 (close fd/port)
-	 fd)
-	(else
-	 (primitive-move->fdes fd/port fd)
-	 (set-port-revealed! fd/port 1)
-	 fd/port)))
+         (dup->fdes fd/port fd)
+         (close fd/port)
+         fd)
+        (else
+         (primitive-move->fdes fd/port fd)
+         (set-port-revealed! fd/port 1)
+         fd/port)))
 
 (define (release-port-handle port)
   (let ((revealed (port-revealed port)))
     (if (> revealed 0)
-	(set-port-revealed! port (- revealed 1)))))
-
-(define (dup->port port/fd mode . maybe-fd)
-  (let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
-		      mode)))
-    (if (pair? maybe-fd)
-	(set-port-revealed! port 1))
-    port))
-
-(define (dup->inport port/fd . maybe-fd)
-  (apply dup->port port/fd "r" maybe-fd))
-
-(define (dup->outport port/fd . maybe-fd)
-  (apply dup->port port/fd "w" maybe-fd))
-
-(define (dup port/fd . maybe-fd)
-  (if (integer? port/fd)
-      (apply dup->fdes port/fd maybe-fd)
-      (apply dup->port port/fd (port-mode port/fd) maybe-fd)))
+        (set-port-revealed! port (- revealed 1)))))
+
+(define dup->port
+  (case-lambda
+    ((port/fd mode)
+     (fdopen (dup->fdes port/fd) mode))
+    ((port/fd mode new-fd)
+     (let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
+       (set-port-revealed! port 1)
+       port))))
+
+(define dup->inport
+  (case-lambda
+    ((port/fd)
+     (dup->port port/fd "r"))
+    ((port/fd new-fd)
+     (dup->port port/fd "r" new-fd))))
+
+(define dup->outport
+  (case-lambda
+    ((port/fd)
+     (dup->port port/fd "w"))
+    ((port/fd new-fd)
+     (dup->port port/fd "w" new-fd))))
+
+(define dup
+  (case-lambda
+    ((port/fd)
+     (if (integer? port/fd)
+         (dup->fdes port/fd)
+         (dup->port port/fd (port-mode port/fd))))
+    ((port/fd new-fd)
+     (if (integer? port/fd)
+         (dup->fdes port/fd new-fd)
+         (dup->port port/fd (port-mode port/fd) new-fd)))))
 
 (define (duplicate-port port modes)
   (dup->port port modes))
@@ -780,28 +966,28 @@
 (define (fdes->inport fdes)
   (let loop ((rest-ports (fdes->ports fdes)))
     (cond ((null? rest-ports)
-	   (let ((result (fdopen fdes "r")))
-	     (set-port-revealed! result 1)
-	     result))
-	  ((input-port? (car rest-ports))
-	   (set-port-revealed! (car rest-ports)
-			       (+ (port-revealed (car rest-ports)) 1))
-	   (car rest-ports))
-	  (else
-	   (loop (cdr rest-ports))))))
+           (let ((result (fdopen fdes "r")))
+             (set-port-revealed! result 1)
+             result))
+          ((input-port? (car rest-ports))
+           (set-port-revealed! (car rest-ports)
+                               (+ (port-revealed (car rest-ports)) 1))
+           (car rest-ports))
+          (else
+           (loop (cdr rest-ports))))))
 
 (define (fdes->outport fdes)
   (let loop ((rest-ports (fdes->ports fdes)))
     (cond ((null? rest-ports)
-	   (let ((result (fdopen fdes "w")))
-	     (set-port-revealed! result 1)
-	     result))
-	  ((output-port? (car rest-ports))
-	   (set-port-revealed! (car rest-ports)
-			       (+ (port-revealed (car rest-ports)) 1))
-	   (car rest-ports))
-	  (else
-	   (loop (cdr rest-ports))))))
+           (let ((result (fdopen fdes "w")))
+             (set-port-revealed! result 1)
+             result))
+          ((output-port? (car rest-ports))
+           (set-port-revealed! (car rest-ports)
+                               (+ (port-revealed (car rest-ports)) 1))
+           (car rest-ports))
+          (else
+           (loop (cdr rest-ports))))))
 
 (define (port->fdes port)
   (set-port-revealed! port (+ (port-revealed port) 1))
@@ -827,15 +1013,15 @@
 
 (define (in-vicinity vicinity file)
   (let ((tail (let ((len (string-length vicinity)))
-		(if (zero? len)
-		    #f
-		    (string-ref vicinity (- len 1))))))
+                (if (zero? len)
+                    #f
+                    (string-ref vicinity (- len 1))))))
     (string-append vicinity
-		   (if (or (not tail)
-			   (eq? tail #\/))
-		       ""
-		       "/")
-		   file)))
+                   (if (or (not tail)
+                           (eq? tail #\/))
+                       ""
+                       "/")
+                   file)))
 
 
 
@@ -858,19 +1044,32 @@
 
 (define (load-user-init)
   (let* ((home (or (getenv "HOME")
-		   (false-if-exception (passwd:dir (getpwuid (getuid))))
-		   "/"))  ;; fallback for cygwin etc.
-	 (init-file (in-vicinity home ".guile")))
+                   (false-if-exception (passwd:dir (getpwuid (getuid))))
+                   "/"))  ;; fallback for cygwin etc.
+         (init-file (in-vicinity home ".guile")))
     (if (file-exists? init-file)
-	(primitive-load init-file))))
+        (primitive-load init-file))))
 
 
 
 ;;; {The interpreter stack}
 ;;;
 
-(defmacro start-stack (tag exp)
-  `(%start-stack ,tag (lambda () ,exp)))
+;; %stacks defined in stacks.c
+(define (%start-stack tag thunk)
+  (let ((prompt-tag (make-prompt-tag "start-stack")))
+    (call-with-prompt
+     prompt-tag
+     (lambda ()
+       (with-fluids ((%stacks (acons tag prompt-tag
+                                     (or (fluid-ref %stacks) '()))))
+         (thunk)))
+     (lambda (k . args)
+              (%start-stack tag (lambda () (apply k args)))))))
+(define-syntax start-stack
+  (syntax-rules ()
+    ((_ tag exp)
+     (%start-stack tag (lambda () exp)))))
 
 
 
@@ -882,7 +1081,7 @@
 ;;; name extensions listed in %load-extensions.
 (define (load-from-path name)
   (start-stack 'load-stack
-	       (primitive-load-path name)))
+               (primitive-load-path name)))
 
 (define %load-verbosely #f)
 (define (assert-load-verbosity v) (set! %load-verbosely v))
@@ -890,138 +1089,71 @@
 (define (%load-announce file)
   (if %load-verbosely
       (with-output-to-port (current-error-port)
-	(lambda ()
-	  (display ";;; ")
-	  (display "loading ")
-	  (display file)
-	  (newline)
-	  (force-output)))))
+        (lambda ()
+          (display ";;; ")
+          (display "loading ")
+          (display file)
+          (newline)
+          (force-output)))))
 
 (set! %load-hook %load-announce)
 
-;;; Returns the .go file corresponding to `name'. Does not search load
-;;; paths, only the fallback path. If the .go file is missing or out of
-;;; date, and autocompilation is enabled, will try autocompilation, just
-;;; as primitive-load-path does internally. primitive-load is
-;;; unaffected. Returns #f if autocompilation failed or was disabled.
-(define (autocompiled-file-name name)
-  (catch #t
-    (lambda ()
-      (let* ((cfn ((@ (system base compile) compiled-file-name) name))
-             (scmstat (stat name))
-             (gostat (stat cfn #f)))
-        (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
-            cfn
-            (begin
-              (if gostat
-                  (format (current-error-port)
-                    ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
-                    name cfn))
-              (cond
-               (%load-should-autocompile
-                (%warn-autocompilation-enabled)
-                (format (current-error-port) ";;; compiling ~a\n" name)
-                (let ((cfn ((@ (system base compile) compile-file) name)))
-                  (format (current-error-port) ";;; compiled ~a\n" cfn)
-                  cfn))
-               (else #f))))))
-    (lambda (k . args)
-      (format (current-error-port)
-              ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
-              name k args)
-      #f)))
-
-(define (load name . reader)
-  (with-fluid* current-reader (and (pair? reader) (car reader))
-    (lambda ()
-      (let ((cfn (autocompiled-file-name name)))
-        (if cfn
-            (load-compiled cfn)
-            (start-stack 'load-stack
-                         (primitive-load name)))))))
-
-
-
-;;; {Transcendental Functions}
-;;;
-;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Written by Jerry D. Hedden, (C) FSF.
-;;; See the file `COPYING' for terms applying to this program.
-;;;
-
-(define expt
-  (let ((integer-expt integer-expt))
-    (lambda (z1 z2)
-      (cond ((and (exact? z2) (integer? z2))
-	     (integer-expt z1 z2))
-	    ((and (real? z2) (real? z1) (>= z1 0))
-	     ($expt z1 z2))
-	    (else
-	     (exp (* z2 (log z1))))))))
-
-(define (sinh z)
-  (if (real? z) ($sinh z)
-      (let ((x (real-part z)) (y (imag-part z)))
-	(make-rectangular (* ($sinh x) ($cos y))
-			  (* ($cosh x) ($sin y))))))
-(define (cosh z)
-  (if (real? z) ($cosh z)
-      (let ((x (real-part z)) (y (imag-part z)))
-	(make-rectangular (* ($cosh x) ($cos y))
-			  (* ($sinh x) ($sin y))))))
-(define (tanh z)
-  (if (real? z) ($tanh z)
-      (let* ((x (* 2 (real-part z)))
-	     (y (* 2 (imag-part z)))
-	     (w (+ ($cosh x) ($cos y))))
-	(make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
-
-(define (asinh z)
-  (if (real? z) ($asinh z)
-      (log (+ z (sqrt (+ (* z z) 1))))))
-
-(define (acosh z)
-  (if (and (real? z) (>= z 1))
-      ($acosh z)
-      (log (+ z (sqrt (- (* z z) 1))))))
-
-(define (atanh z)
-  (if (and (real? z) (> z -1) (< z 1))
-      ($atanh z)
-      (/ (log (/ (+ 1 z) (- 1 z))) 2)))
-
-(define (sin z)
-  (if (real? z) ($sin z)
-      (let ((x (real-part z)) (y (imag-part z)))
-	(make-rectangular (* ($sin x) ($cosh y))
-			  (* ($cos x) ($sinh y))))))
-(define (cos z)
-  (if (real? z) ($cos z)
-      (let ((x (real-part z)) (y (imag-part z)))
-	(make-rectangular (* ($cos x) ($cosh y))
-			  (- (* ($sin x) ($sinh y)))))))
-(define (tan z)
-  (if (real? z) ($tan z)
-      (let* ((x (* 2 (real-part z)))
-	     (y (* 2 (imag-part z)))
-	     (w (+ ($cos x) ($cosh y))))
-	(make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
-
-(define (asin z)
-  (if (and (real? z) (>= z -1) (<= z 1))
-      ($asin z)
-      (* -i (asinh (* +i z)))))
-
-(define (acos z)
-  (if (and (real? z) (>= z -1) (<= z 1))
-      ($acos z)
-      (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
-
-(define (atan z . y)
-  (if (null? y)
-      (if (real? z) ($atan z)
-	  (/ (log (/ (- +i z) (+ +i z))) +2i))
-      ($atan2 z (car y))))
+(define* (load name #:optional reader)
+  ;; Returns the .go file corresponding to `name'. Does not search load
+  ;; paths, only the fallback path. If the .go file is missing or out of
+  ;; date, and autocompilation is enabled, will try autocompilation, just
+  ;; as primitive-load-path does internally. primitive-load is
+  ;; unaffected. Returns #f if autocompilation failed or was disabled.
+  ;;
+  ;; NB: Unless we need to compile the file, this function should not cause
+  ;; (system base compile) to be loaded up. For that reason compiled-file-name
+  ;; partially duplicates functionality from (system base compile).
+  (define (compiled-file-name canon-path)
+    (and %compile-fallback-path
+         (string-append
+          %compile-fallback-path
+          ;; no need for '/' separator here, canon-path is absolute
+          canon-path
+          (cond ((or (null? %load-compiled-extensions)
+                     (string-null? (car %load-compiled-extensions)))
+                 (warn "invalid %load-compiled-extensions"
+                       %load-compiled-extensions)
+                 ".go")
+                (else (car %load-compiled-extensions))))))
+  (define (fresh-compiled-file-name go-path)
+    (catch #t
+      (lambda ()
+        (let* ((scmstat (stat name))
+               (gostat (stat go-path #f)))
+          (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+              go-path
+              (begin
+                (if gostat
+                    (format (current-error-port)
+                            ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
+                            name go-path))
+                (cond
+                 (%load-should-autocompile
+                  (%warn-autocompilation-enabled)
+                  (format (current-error-port) ";;; compiling ~a\n" name)
+                  (let ((cfn ((@ (system base compile) compile-file) name
+                              #:env (current-module))))
+                    (format (current-error-port) ";;; compiled ~a\n" cfn)
+                    cfn))
+                 (else #f))))))
+      (lambda (k . args)
+        (format (current-error-port)
+                ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+                name k args)
+        #f)))
+  (with-fluids ((current-reader reader))
+    (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
+                             compiled-file-name)
+                      fresh-compiled-file-name)))
+      (if cfn
+          (load-compiled cfn)
+          (start-stack 'load-stack
+                       (primitive-load name))))))
 
 
 
@@ -1050,117 +1182,117 @@
     (return #f #f argv))
 
    ((or (not (eq? #\- (string-ref (car argv) 0)))
-	(eq? (string-length (car argv)) 1))
+        (eq? (string-length (car argv)) 1))
     (return 'normal-arg (car argv) (cdr argv)))
 
    ((eq? #\- (string-ref (car argv) 1))
     (let* ((kw-arg-pos (or (string-index (car argv) #\=)
-			   (string-length (car argv))))
-	   (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
-	   (kw-opt? (member kw kw-opts))
-	   (kw-arg? (member kw kw-args))
-	   (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
-			 (substring (car argv)
-				    (+ kw-arg-pos 1)
-				    (string-length (car argv))))
-		    (and kw-arg?
-			 (begin (set! argv (cdr argv)) (car argv))))))
+                           (string-length (car argv))))
+           (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+           (kw-opt? (member kw kw-opts))
+           (kw-arg? (member kw kw-args))
+           (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+                         (substring (car argv)
+                                    (+ kw-arg-pos 1)
+                                    (string-length (car argv))))
+                    (and kw-arg?
+                         (begin (set! argv (cdr argv)) (car argv))))))
       (if (or kw-opt? kw-arg?)
-	  (return kw arg (cdr argv))
-	  (return 'usage-error kw (cdr argv)))))
+          (return kw arg (cdr argv))
+          (return 'usage-error kw (cdr argv)))))
 
    (else
     (let* ((char (substring (car argv) 1 2))
-	   (kw (symbol->keyword char)))
+           (kw (symbol->keyword char)))
       (cond
 
        ((member kw kw-opts)
-	(let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
-	       (new-argv (if (= 0 (string-length rest-car))
-			     (cdr argv)
-			     (cons (string-append "-" rest-car) (cdr argv)))))
-	  (return kw #f new-argv)))
+        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+               (new-argv (if (= 0 (string-length rest-car))
+                             (cdr argv)
+                             (cons (string-append "-" rest-car) (cdr argv)))))
+          (return kw #f new-argv)))
 
        ((member kw kw-args)
-	(let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
-	       (arg (if (= 0 (string-length rest-car))
-			(cadr argv)
-			rest-car))
-	       (new-argv (if (= 0 (string-length rest-car))
-			     (cddr argv)
-			     (cdr argv))))
-	  (return kw arg new-argv)))
+        (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+               (arg (if (= 0 (string-length rest-car))
+                        (cadr argv)
+                        rest-car))
+               (new-argv (if (= 0 (string-length rest-car))
+                             (cddr argv)
+                             (cdr argv))))
+          (return kw arg new-argv)))
 
        (else (return 'usage-error kw argv)))))))
 
 (define (for-next-option proc argv kw-opts kw-args)
   (let loop ((argv argv))
     (get-option argv kw-opts kw-args
-		(lambda (opt opt-arg argv)
-		  (and opt (proc opt opt-arg argv loop))))))
+                (lambda (opt opt-arg argv)
+                  (and opt (proc opt opt-arg argv loop))))))
 
 (define (display-usage-report kw-desc)
   (for-each
    (lambda (kw)
      (or (eq? (car kw) #t)
-	 (eq? (car kw) 'else)
-	 (let* ((opt-desc kw)
-		(help (cadr opt-desc))
-		(opts (car opt-desc))
-		(opts-proper (if (string? (car opts)) (cdr opts) opts))
-		(arg-name (if (string? (car opts))
-			      (string-append "<" (car opts) ">")
-			      ""))
-		(left-part (string-append
-			    (with-output-to-string
-			      (lambda ()
-				(map (lambda (x) (display (keyword->symbol x)) (display " "))
-				     opts-proper)))
-			    arg-name))
-		(middle-part (if (and (< (string-length left-part) 30)
-				      (< (string-length help) 40))
-				 (make-string (- 30 (string-length left-part)) #\ )
-				 "\n\t")))
-	   (display left-part)
-	   (display middle-part)
-	   (display help)
-	   (newline))))
+         (eq? (car kw) 'else)
+         (let* ((opt-desc kw)
+                (help (cadr opt-desc))
+                (opts (car opt-desc))
+                (opts-proper (if (string? (car opts)) (cdr opts) opts))
+                (arg-name (if (string? (car opts))
+                              (string-append "<" (car opts) ">")
+                              ""))
+                (left-part (string-append
+                            (with-output-to-string
+                              (lambda ()
+                                (map (lambda (x) (display (keyword->symbol x)) (display " "))
+                                     opts-proper)))
+                            arg-name))
+                (middle-part (if (and (< (string-length left-part) 30)
+                                      (< (string-length help) 40))
+                                 (make-string (- 30 (string-length left-part)) #\ )
+                                 "\n\t")))
+           (display left-part)
+           (display middle-part)
+           (display help)
+           (newline))))
    kw-desc))
 
 
 
 (define (transform-usage-lambda cases)
   (let* ((raw-usage (delq! 'else (map car cases)))
-	 (usage-sans-specials (map (lambda (x)
-				    (or (and (not (list? x)) x)
-					(and (symbol? (car x)) #t)
-					(and (boolean? (car x)) #t)
-					x))
-				  raw-usage))
-	 (usage-desc (delq! #t usage-sans-specials))
-	 (kw-desc (map car usage-desc))
-	 (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
-	 (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
-	 (transmogrified-cases (map (lambda (case)
-				      (cons (let ((opts (car case)))
-					      (if (or (boolean? opts) (eq? 'else opts))
-						  opts
-						  (cond
-						   ((symbol? (car opts))  opts)
-						   ((boolean? (car opts)) opts)
-						   ((string? (caar opts)) (cdar opts))
-						   (else (car opts)))))
-					    (cdr case)))
-				    cases)))
+         (usage-sans-specials (map (lambda (x)
+                                    (or (and (not (list? x)) x)
+                                        (and (symbol? (car x)) #t)
+                                        (and (boolean? (car x)) #t)
+                                        x))
+                                  raw-usage))
+         (usage-desc (delq! #t usage-sans-specials))
+         (kw-desc (map car usage-desc))
+         (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
+         (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
+         (transmogrified-cases (map (lambda (case)
+                                      (cons (let ((opts (car case)))
+                                              (if (or (boolean? opts) (eq? 'else opts))
+                                                  opts
+                                                  (cond
+                                                   ((symbol? (car opts))  opts)
+                                                   ((boolean? (car opts)) opts)
+                                                   ((string? (caar opts)) (cdar opts))
+                                                   (else (car opts)))))
+                                            (cdr case)))
+                                    cases)))
     `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
        (lambda (%argv)
-	 (let %next-arg ((%argv %argv))
-	   (get-option %argv
-		       ',kw-opts
-		       ',kw-args
-		       (lambda (%opt %arg %new-argv)
-			 (case %opt
-			   ,@ transmogrified-cases))))))))
+         (let %next-arg ((%argv %argv))
+           (get-option %argv
+                       ',kw-opts
+                       ',kw-args
+                       (lambda (%opt %arg %new-argv)
+                         (case %opt
+                           ,@ transmogrified-cases))))))))
 
 
 
@@ -1287,7 +1419,7 @@
 ;;; (module-local-variable module symbol) => [#<variable ...> | #f]
 ;;; (module-variable module symbol) => [#<variable ...> | #f]
 ;;; (module-symbol-binding module symbol opt-value)
-;;;		=> [ <obj> | opt-value | an error occurs ]
+;;;             => [ <obj> | opt-value | an error occurs ]
 ;;; (module-make-local-var! module symbol) => #<variable...>
 ;;; (module-add! module symbol var) => unspecified
 ;;; (module-remove! module symbol) =>  unspecified
@@ -1304,12 +1436,7 @@
 ;;;
 
 ;; 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
-;; the value stored in the vtable that determines how record are
-;; printed. Sigh.)
-
-(define (%print-module mod port)  ; unused args: depth length style table)
+(define (%print-module mod port)
   (display "#<" port)
   (display (or (module-kind mod) "module") port)
   (display " " port)
@@ -1318,23 +1445,145 @@
   (display (number->string (object-address mod) 16) port)
   (display ">" port))
 
-;; module-type
-;;
-;; A module is characterized by an obarray in which local symbols
-;; are interned, a list of modules, "uses", from which non-local
-;; bindings can be inherited, and an optional lazy-binder which
-;; 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 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 import-obarray
-		      observers weak-observers)
-		    %print-module))
+(letrec-syntax
+     ;; Locally extend the syntax to allow record accessors to be defined at
+     ;; compile-time. Cache the rtd locally to the constructor, the getters and
+     ;; the setters, in order to allow for redefinition of the record type; not
+     ;; relevant in the case of modules, but perhaps if we make this public, it
+     ;; could matter.
+
+    ((define-record-type
+       (lambda (x)
+         (define (make-id scope . fragments)
+           (datum->syntax #'scope
+                          (apply symbol-append
+                                 (map (lambda (x)
+                                        (if (symbol? x) x (syntax->datum x)))
+                                      fragments))))
+         
+         (define (getter rtd type-name field slot)
+           #`(define #,(make-id rtd type-name '- field)
+               (let ((rtd #,rtd))
+                 (lambda (#,type-name)
+                   (if (eq? (struct-vtable #,type-name) rtd)
+                       (struct-ref #,type-name #,slot)
+                       (%record-type-error rtd #,type-name))))))
+
+         (define (setter rtd type-name field slot)
+           #`(define #,(make-id rtd 'set- type-name '- field '!)
+               (let ((rtd #,rtd))
+                 (lambda (#,type-name val)
+                   (if (eq? (struct-vtable #,type-name) rtd)
+                       (struct-set! #,type-name #,slot val)
+                       (%record-type-error rtd #,type-name))))))
+
+         (define (accessors rtd type-name fields n exp)
+           (syntax-case fields ()
+             (() exp)
+             (((field #:no-accessors) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         exp))
+             (((field #:no-setter) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(getter rtd type-name #'field n))))
+             (((field #:no-getter) field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(setter rtd type-name #'field n))))
+             ((field field* ...) (identifier? #'field)
+              (accessors rtd type-name #'(field* ...) (1+ n)
+                         #`(begin #,exp
+                                  #,(getter rtd type-name #'field n)
+                                  #,(setter rtd type-name #'field n))))))
+
+         (define (predicate rtd type-name fields exp)
+           (accessors
+            rtd type-name fields 0
+            #`(begin
+                #,exp
+                (define (#,(make-id rtd type-name '?) obj)
+                  (and (struct? obj) (eq? (struct-vtable obj) #,rtd))))))
+
+         (define (field-list fields)
+           (syntax-case fields ()
+             (() '())
+             (((f . opts) . rest) (identifier? #'f)
+              (cons #'f (field-list #'rest)))
+             ((f . rest) (identifier? #'f)
+              (cons #'f (field-list #'rest)))))
+
+         (define (constructor rtd type-name fields exp)
+           (let ((ctor (make-id rtd type-name '-constructor))
+                 (args (field-list fields)))
+             (predicate rtd type-name fields
+                        #`(begin #,exp
+                                 (define #,ctor
+                                   (let ((rtd #,rtd))
+                                     (lambda #,args
+                                       (make-struct rtd 0 #,@args))))
+                                 (struct-set! #,rtd (+ vtable-offset-user 2)
+                                              #,ctor)))))
+
+         (define (type type-name printer fields)
+           (define (make-layout)
+             (let lp ((fields fields) (slots '()))
+               (syntax-case fields ()
+                 (() (datum->syntax #'here
+                                    (make-struct-layout
+                                     (apply string-append slots))))
+                 ((_ . rest) (lp #'rest (cons "pw" slots))))))
+
+           (let ((rtd (make-id type-name type-name '-type)))
+             (constructor rtd type-name fields
+                          #`(begin
+                              (define #,rtd
+                                (make-struct record-type-vtable 0
+                                             '#,(make-layout)
+                                             #,printer
+                                             '#,type-name
+                                             '#,(field-list fields)))
+                              (set-struct-vtable-name! #,rtd '#,type-name)))))
+
+         (syntax-case x ()
+           ((_ type-name printer (field ...))
+            (type #'type-name #'printer #'(field ...)))))))
+
+  ;; module-type
+  ;;
+  ;; A module is characterized by an obarray in which local symbols
+  ;; are interned, a list of modules, "uses", from which non-local
+  ;; bindings can be inherited, and an optional lazy-binder which
+  ;; 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 the set of fields or their order, you also need to
+  ;; change the constants in libguile/modules.h.
+  ;;
+  ;; NOTE: The getter `module-eval-closure' is used in libguile/modules.c.
+  ;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
+  ;; NOTE: The getter `module-name' is defined later, due to boot reasons.
+  ;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
+  ;;
+  (define-record-type module
+    (lambda (obj port) (%print-module obj port))
+    (obarray
+     uses
+     binder
+     eval-closure
+     (transformer #:no-getter)
+     (name #:no-getter)
+     kind
+     duplicates-handlers
+     (import-obarray #:no-setter)
+     observers
+     (weak-observers #:no-setter)
+     version
+     submodules
+     submodule-binder
+     public-interface
+     filename)))
+
 
 ;; make-module &opt size uses binder
 ;;
@@ -1345,90 +1594,45 @@
     (lambda args
 
       (define (parse-arg index default)
-	(if (> (length args) index)
-	    (list-ref args index)
-	    default))
+        (if (> (length args) index)
+            (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))
+          (error "Too many args to make-module." args))
 
       (let ((size (parse-arg 0 31))
-	    (uses (parse-arg 1 '()))
-	    (binder (parse-arg 2 #f)))
-
-	(if (not (integer? size))
-	    (error "Illegal size to make-module." size))
-	(if (not (and (list? uses)
-		      (and-map module? uses)))
-	    (error "Incorrect use list." uses))
-	(if (and binder (not (procedure? binder)))
-	    (error
-	     "Lazy-binder expected to be a procedure or #f." binder))
-
-	(let ((module (module-constructor (make-hash-table size)
-					  uses binder #f %pre-modules-transformer
+            (uses (parse-arg 1 '()))
+            (binder (parse-arg 2 #f)))
+
+        (if (not (integer? size))
+            (error "Illegal size to make-module." size))
+        (if (not (and (list? uses)
+                      (and-map module? uses)))
+            (error "Incorrect use list." uses))
+        (if (and binder (not (procedure? binder)))
+            (error
+             "Lazy-binder expected to be a procedure or #f." binder))
+
+        (let ((module (module-constructor (make-hash-table size)
+                                          uses binder #f macroexpand
                                           #f #f #f
-					  (make-hash-table %default-import-size)
-					  '()
-					  (make-weak-key-hash-table 31))))
+                                          (make-hash-table %default-import-size)
+                                          '()
+                                          (make-weak-key-hash-table 31) #f
+                                          (make-hash-table 7) #f #f #f)))
 
-	  ;; We can't pass this as an argument to module-constructor,
-	  ;; because we need it to close over a pointer to the module
-	  ;; itself.
-	  (set-module-eval-closure! module (standard-eval-closure module))
+          ;; We can't pass this as an argument to module-constructor,
+          ;; because we need it to close over a pointer to the module
+          ;; itself.
+          (set-module-eval-closure! module (standard-eval-closure module))
 
-	  module))))
+          module))))
 
-(define module-constructor (record-constructor module-type))
-(define module-obarray  (record-accessor module-type 'obarray))
-(define set-module-obarray! (record-modifier module-type 'obarray))
-(define module-uses  (record-accessor module-type 'uses))
-(define set-module-uses! (record-modifier module-type 'uses))
-(define module-binder (record-accessor module-type 'binder))
-(define set-module-binder! (record-modifier module-type 'binder))
-
-;; NOTE: This binding is used in libguile/modules.c.
-(define module-eval-closure (record-accessor module-type 'eval-closure))
-
-(define module-transformer (record-accessor module-type 'transformer))
-(define set-module-transformer! (record-modifier module-type 'transformer))
-;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
-(define set-module-name! (record-modifier module-type 'name))
-(define module-kind (record-accessor module-type 'kind))
-(define set-module-kind! (record-modifier module-type 'kind))
-(define module-duplicates-handlers
-  (record-accessor module-type 'duplicates-handlers))
-(define set-module-duplicates-handlers!
-  (record-modifier module-type 'duplicates-handlers))
-(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? (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)
-      (setter module closure)
-      ;; Make it possible to lookup the module from the environment.
-      ;; This implementation is correct since an eval closure can belong
-      ;; to maximally one module.
-
-      ;; XXX: The following line introduces a circular reference that
-      ;; precludes garbage collection of modules with the current weak hash
-      ;; table semantics (see
-      ;; http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
-      ;; for details).  Since it doesn't appear to be used (only in
-      ;; `scm_lookup_closure_module ()', which has 1 caller), we just comment
-      ;; it out.
-
-      ;(set-procedure-property! closure 'module module)
-      )))
 
 
 
@@ -1439,7 +1643,7 @@
   (set-module-observers! module (cons proc (module-observers module)))
   (cons module proc))
 
-(define (module-observe-weak module observer-id . proc)
+(define* (module-observe-weak module observer-id #:optional (proc observer-id))
   ;; 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
@@ -1449,16 +1653,14 @@
   ;; 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)))
+  (hashq-set! (module-weak-observers module) observer-id proc))
 
 (define (module-unobserve token)
   (let ((module (car token))
-	(id (cdr token)))
+        (id (cdr token)))
     (if (integer? id)
-	(hash-remove! (module-weak-observers module) id)
-	(set-module-observers! module (delq1! id (module-observers module)))))
+        (hash-remove! (module-weak-observers module) id)
+        (set-module-observers! module (delq1! id (module-observers module)))))
   *unspecified*)
 
 (define module-defer-observers #f)
@@ -1476,16 +1678,16 @@
 (define (call-with-deferred-observers thunk)
   (dynamic-wind
       (lambda ()
-	(lock-mutex module-defer-observers-mutex)
-	(set! module-defer-observers #t))
+        (lock-mutex module-defer-observers-mutex)
+        (set! module-defer-observers #t))
       thunk
       (lambda ()
-	(set! module-defer-observers #f)
-	(hash-for-each (lambda (m dummy)
-			 (module-call-observers m))
-		       module-defer-observers-table)
-	(hash-clear! module-defer-observers-table)
-	(unlock-mutex module-defer-observers-mutex))))
+        (set! module-defer-observers #f)
+        (hash-for-each (lambda (m dummy)
+                         (module-call-observers m))
+                       module-defer-observers-table)
+        (hash-clear! module-defer-observers-table)
+        (unlock-mutex module-defer-observers-mutex))))
 
 (define (module-call-observers m)
   (for-each (lambda (proc) (proc m)) (module-observers m))
@@ -1523,8 +1725,8 @@
 (define (module-search fn m v)
   (define (loop pos)
     (and (pair? pos)
-	 (or (module-search fn (car pos) v)
-	     (loop (cdr pos)))))
+         (or (module-search fn (car pos) v)
+             (loop (cdr pos)))))
   (or (fn m v)
       (loop (module-uses m))))
 
@@ -1542,7 +1744,7 @@
 (define (module-locally-bound? m v)
   (let ((var (module-local-variable m v)))
     (and var
-	 (variable-bound? var))))
+         (variable-bound? var))))
 
 ;; module-bound? module symbol
 ;;
@@ -1552,7 +1754,7 @@
 (define (module-bound? m v)
   (let ((var (module-variable m v)))
     (and var
-	 (variable-bound? var))))
+         (variable-bound? var))))
 
 ;;; {Is a symbol interned in a module?}
 ;;;
@@ -1638,10 +1840,10 @@
 (define (module-symbol-local-binding m v . opt-val)
   (let ((var (module-local-variable m v)))
     (if (and var (variable-bound? var))
-	(variable-ref var)
-	(if (not (null? opt-val))
-	    (car opt-val)
-	    (error "Locally unbound variable." v)))))
+        (variable-ref var)
+        (if (not (null? opt-val))
+            (car opt-val)
+            (error "Locally unbound variable." v)))))
 
 ;; module-symbol-binding module symbol opt-value
 ;;
@@ -1653,10 +1855,10 @@
 (define (module-symbol-binding m v . opt-val)
   (let ((var (module-variable m v)))
     (if (and var (variable-bound? var))
-	(variable-ref var)
-	(if (not (null? opt-val))
-	    (car opt-val)
-	    (error "Unbound variable." v)))))
+        (variable-ref var)
+        (if (not (null? opt-val))
+            (car opt-val)
+            (error "Unbound variable." v)))))
 
 
 
@@ -1674,12 +1876,12 @@
 ;;
 (define (module-make-local-var! m v)
   (or (let ((b (module-obarray-ref (module-obarray m) v)))
-	(and (variable? b)
-	     (begin
-	       ;; Mark as modified since this function is called when
-	       ;; the standard eval closure defines a binding
-	       (module-modified m)
-	       b)))
+        (and (variable? b)
+             (begin
+               ;; Mark as modified since this function is called when
+               ;; the standard eval closure defines a binding
+               (module-modified m)
+               b)))
 
       ;; Create a new local variable.
       (let ((local-var (make-undefined-variable)))
@@ -1695,8 +1897,8 @@
 (define (module-ensure-local-variable! module symbol)
   (or (module-local-variable module symbol)
       (let ((var (make-undefined-variable)))
-	(module-add! module symbol var)
-	var)))
+        (module-add! module symbol var)
+        var)))
 
 ;; module-add! module symbol var
 ;;
@@ -1730,6 +1932,20 @@
 (define (module-map proc module)
   (hash-map->list proc (module-obarray module)))
 
+;; Submodules
+;;
+;; Modules exist in a separate namespace from values, because you generally do
+;; not want the name of a submodule, which you might not even use, to collide
+;; with local variables that happen to be named the same as the submodule.
+;;
+(define (module-ref-submodule module name)
+  (or (hashq-ref (module-submodules module) name)
+      (and (module-submodule-binder module)
+           ((module-submodule-binder module) module name))))
+
+(define (module-define-submodule! module name submodule)
+  (hashq-set! (module-submodules module) name submodule))
+
 
 
 ;;; {Low Level Bootstrapping}
@@ -1768,32 +1984,31 @@
 
 (define (save-module-excursion thunk)
   (let ((inner-module (current-module))
-	(outer-module #f))
+        (outer-module #f))
     (dynamic-wind (lambda ()
-		    (set! outer-module (current-module))
-		    (set-current-module inner-module)
-		    (set! inner-module #f))
-		  thunk
-		  (lambda ()
-		    (set! inner-module (current-module))
-		    (set-current-module outer-module)
-		    (set! outer-module #f)))))
+                    (set! outer-module (current-module))
+                    (set-current-module inner-module)
+                    (set! inner-module #f))
+                  thunk
+                  (lambda ()
+                    (set! inner-module (current-module))
+                    (set-current-module outer-module)
+                    (set! outer-module #f)))))
 
 (define basic-load load)
 
-(define (load-module filename . reader)
+(define* (load-module filename #:optional reader)
   (save-module-excursion
    (lambda ()
      (let ((oldname (and (current-load-port)
-			 (port-filename (current-load-port)))))
-       (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)))))
+                         (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)
+                   reader)))))
 
 
 
@@ -1808,11 +2023,11 @@
 (define (module-ref module name . rest)
   (let ((variable (module-variable module name)))
     (if (and variable (variable-bound? variable))
-	(variable-ref variable)
-	(if (null? rest)
-	    (error "No variable named" name 'in module)
-	    (car rest)			; default value
-	    ))))
+        (variable-ref variable)
+        (if (null? rest)
+            (error "No variable named" name 'in module)
+            (car rest)                  ; default value
+            ))))
 
 ;; MODULE-SET! -- exported
 ;;
@@ -1822,8 +2037,8 @@
 (define (module-set! module name value)
   (let ((variable (module-variable module name)))
     (if variable
-	(variable-set! variable value)
-	(error "No variable named" name 'in module))))
+        (variable-set! variable value)
+        (error "No variable named" name 'in module))))
 
 ;; MODULE-DEFINE! -- exported
 ;;
@@ -1833,11 +2048,11 @@
 (define (module-define! module name value)
   (let ((variable (module-local-variable module name)))
     (if variable
-	(begin
-	  (variable-set! variable value)
-	  (module-modified module))
-	(let ((variable (make-variable value)))
-	  (module-add! module name variable)))))
+        (begin
+          (variable-set! variable value)
+          (module-modified module))
+        (let ((variable (make-variable value)))
+          (module-add! module name variable)))))
 
 ;; MODULE-DEFINED? -- exported
 ;;
@@ -1866,7 +2081,7 @@
                                                      (module-name interface))))
                                           (module-uses module))
                                   (list interface)))
-
+        (hash-clear! (module-import-obarray module))
         (module-modified module))))
 
 ;; MODULE-USE-INTERFACES! module interfaces
@@ -1876,6 +2091,7 @@
 (define (module-use-interfaces! module interfaces)
   (set-module-uses! module
                     (append (module-uses module) interfaces))
+  (hash-clear! (module-import-obarray module))
   (module-modified module))
 
 
@@ -1883,88 +2099,137 @@
 ;;; {Recursive Namespaces}
 ;;;
 ;;; A hierarchical namespace emerges if we consider some module to be
-;;; root, and variables bound to modules as nested namespaces.
+;;; root, and submodules of that module to be nested namespaces.
 ;;;
-;;; The routines in this file manage variable names in hierarchical namespace.
+;;; The routines here manage variable names in hierarchical namespace.
 ;;; Each variable name is a list of elements, looked up in successively nested
 ;;; modules.
 ;;;
-;;;		(nested-ref some-root-module '(foo bar baz))
-;;;		=> <value of a variable named baz in the module bound to bar in
-;;;		    the module bound to foo in some-root-module>
+;;;             (nested-ref some-root-module '(foo bar baz))
+;;;             => <value of a variable named baz in the submodule bar of
+;;;                 the submodule foo of some-root-module>
 ;;;
 ;;;
 ;;; There are:
 ;;;
-;;;	;; a-root is a module
-;;;	;; name is a list of symbols
+;;;     ;; a-root is a module
+;;;     ;; name is a list of symbols
 ;;;
-;;;	nested-ref a-root name
-;;;	nested-set! a-root name val
-;;;	nested-define! a-root name val
-;;;	nested-remove! a-root name
+;;;     nested-ref a-root name
+;;;     nested-set! a-root name val
+;;;     nested-define! a-root name val
+;;;     nested-remove! a-root name
 ;;;
+;;; These functions manipulate values in namespaces. For referencing the
+;;; namespaces themselves, use the following:
 ;;;
-;;; (current-module) is a natural choice for a-root so for convenience there are
+;;;     nested-ref-module a-root name
+;;;     nested-define-module! a-root name mod
+;;;
+;;; (current-module) is a natural choice for a root so for convenience there are
 ;;; also:
 ;;;
-;;;	local-ref name		==	nested-ref (current-module) name
-;;;	local-set! name val	==	nested-set! (current-module) name val
-;;;	local-define! name val	==	nested-define! (current-module) name val
-;;;	local-remove! name	==	nested-remove! (current-module) name
+;;;     local-ref name                ==  nested-ref (current-module) name
+;;;     local-set! name val           ==  nested-set! (current-module) name val
+;;;     local-define name val         ==  nested-define! (current-module) name val
+;;;     local-remove name             ==  nested-remove! (current-module) name
+;;;     local-ref-module name         ==  nested-ref-module (current-module) name
+;;;     local-define-module! name m   ==  nested-define-module! (current-module) name m
 ;;;
 
 
 (define (nested-ref root names)
-  (let loop ((cur root)
-	     (elts names))
-    (cond
-     ((null? elts)		cur)
-     ((not (module? cur))	#f)
-     (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
+  (if (null? names)
+      root
+      (let loop ((cur root)
+                 (head (car names))
+                 (tail (cdr names)))
+        (if (null? tail)
+            (module-ref cur head #f)
+            (let ((cur (module-ref-submodule cur head)))
+              (and cur
+                   (loop cur (car tail) (cdr tail))))))))
 
 (define (nested-set! root names val)
   (let loop ((cur root)
-	     (elts names))
-    (if (null? (cdr elts))
-	(module-set! cur (car elts) val)
-	(loop (module-ref cur (car elts)) (cdr elts)))))
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-set! cur head val)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
 
 (define (nested-define! root names val)
   (let loop ((cur root)
-	     (elts names))
-    (if (null? (cdr elts))
-	(module-define! cur (car elts) val)
-	(loop (module-ref cur (car elts)) (cdr elts)))))
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-define! cur head val)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
 
 (define (nested-remove! root names)
   (let loop ((cur root)
-	     (elts names))
-    (if (null? (cdr elts))
-	(module-remove! cur (car elts))
-	(loop (module-ref cur (car elts)) (cdr elts)))))
+             (head (car names))
+             (tail (cdr names)))
+    (if (null? tail)
+        (module-remove! cur head)
+        (let ((cur (module-ref-submodule cur head)))
+          (if (not cur)
+              (error "failed to resolve module" names)
+              (loop cur (car tail) (cdr tail)))))))
+
+
+(define (nested-ref-module root names)
+  (let loop ((cur root)
+             (names names))
+    (if (null? names)
+        cur
+        (let ((cur (module-ref-submodule cur (car names))))
+          (and cur
+               (loop cur (cdr names)))))))
+
+(define (nested-define-module! root names module)
+  (if (null? names)
+      (error "can't redefine root module" root module)
+      (let loop ((cur root)
+                 (head (car names))
+                 (tail (cdr names)))
+        (if (null? tail)
+            (module-define-submodule! cur head module)
+            (let ((cur (or (module-ref-submodule cur head)
+                           (let ((m (make-module 31)))
+                             (set-module-kind! m 'directory)
+                             (set-module-name! m (append (module-name cur)
+                                                         (list head)))
+                             (module-define-submodule! cur head m)
+                             m))))
+              (loop cur (car tail) (cdr tail)))))))
+
 
 (define (local-ref names) (nested-ref (current-module) names))
 (define (local-set! names val) (nested-set! (current-module) names val))
 (define (local-define names val) (nested-define! (current-module) names val))
 (define (local-remove names) (nested-remove! (current-module) names))
+(define (local-ref-module names) (nested-ref-module (current-module) names))
+(define (local-define-module names mod) (nested-define-module! (current-module) names mod))
+
 
 
 
 
-;;; {The (%app) module}
-;;;
-;;; The root of conventionally named objects not directly in the top level.
+;;; {The (guile) module}
 ;;;
-;;; (%app modules)
-;;; (%app modules guile)
-;;;
-;;; The directory of all modules and the standard root module.
+;;; The standard module, which has the core Guile bindings. Also called the
+;;; "root module", as it is imported by many other modules, but it is not
+;;; necessarily the root of anything; and indeed, the module named '() might be
+;;; better thought of as a root.
 ;;;
 
-;; module-public-interface is defined in C.
-(define (set-module-public-interface! m i)
-  (module-define! m '%module-public-interface i))
 (define (set-system-module! m s)
   (set-procedure-property! (module-eval-closure m) 'system-module s))
 (define the-root-module (make-root-module))
@@ -1976,109 +2241,211 @@
 (set-system-module! the-root-module #t)
 (set-system-module! the-scm-module #t)
 
-;; NOTE: This binding is used in libguile/modules.c.
-;;
-(define (make-modules-in module name)
-  (if (null? name)
-      module
-      (make-modules-in
-       (let* ((var (module-local-variable module (car name)))
-              (val (and var (variable-bound? var) (variable-ref var))))
-         (if (module? val)
-             val
-             (let ((m (make-module 31)))
-               (set-module-kind! m 'directory)
-               (set-module-name! m (append (module-name module)
-                                           (list (car name))))
-               (module-define! module (car name) m)
-               m)))
-       (cdr name))))
 
-(define (beautify-user-module! module)
-  (let ((interface (module-public-interface module)))
-    (if (or (not interface)
-	    (eq? interface module))
-	(let ((interface (make-module 31)))
-	  (set-module-name! interface (module-name module))
-	  (set-module-kind! interface 'interface)
-	  (set-module-public-interface! module interface))))
-  (if (and (not (memq the-scm-module (module-uses module)))
-	   (not (eq? module the-root-module)))
-      ;; 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.
+;; Now that we have a root module, even though modules aren't fully booted,
+;; expand the definition of resolve-module.
 ;;
-(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))
-                  (autoload (or (null? maybe-autoload) (car maybe-autoload))))
-              (cond
-               ((and already (module? already)
-                     (or (not autoload) (module-public-interface already)))
-                ;; A hit, a palpable hit.
-                already)
-               (autoload
-                ;; Try to autoload the module, and recurse.
-                (try-load-module name)
-                (resolve-module name #f))
-               (else
-                ;; A module is not bound (but maybe something else is),
-                ;; we're not autoloading -- here's the weird semantics,
-                ;; we create an empty module.
-                (make-modules-in the-root-module full-name)))))))))
+(define (resolve-module name . args)
+  (if (equal? name '(guile))
+      the-root-module
+      (error "unexpected module to resolve during module boot" 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.
 ;;
-(define try-module-autoload #f)
 (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))
-(set-module-name! %app '(%app))
-(define app %app) ;; for backwards compatability
-
-(let ((m (make-module 31)))
-  (set-module-name! m '())
-  (local-define '(%app modules) m))
-(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)
-;; definition deferred for syncase's benefit.
+
+
+
+
+;; Now that modules are booted, give module-name its final definition.
+;;
 (define module-name
   (let ((accessor (record-accessor module-type 'name)))
     (lambda (mod)
       (or (accessor mod)
           (let ((name (list (gensym))))
-            ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
-            ;; to `resolve-module'.  This is important as `psyntax' stores
-            ;; module names and relies on being able to `resolve-module'
-            ;; them.
+            ;; Name MOD and bind it in the module root so that it's visible to
+            ;; `resolve-module'. This is important as `psyntax' stores module
+            ;; names and relies on being able to `resolve-module' them.
             (set-module-name! mod name)
-            (nested-define! the-root-module `(%app modules ,@name) mod)
+            (nested-define-module! (resolve-module '() #f) name mod)
             (accessor mod))))))
 
-;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
+(define (make-modules-in module name)
+  (or (nested-ref-module module name)
+      (let ((m (make-module 31)))
+        (set-module-kind! m 'directory)
+        (set-module-name! m (append (module-name module) name))
+        (nested-define-module! module name m)
+        m)))
+
+(define (beautify-user-module! module)
+  (let ((interface (module-public-interface module)))
+    (if (or (not interface)
+            (eq? interface module))
+        (let ((interface (make-module 31)))
+          (set-module-name! interface (module-name module))
+          (set-module-version! interface (module-version module))
+          (set-module-kind! interface 'interface)
+          (set-module-public-interface! module interface))))
+  (if (and (not (memq the-scm-module (module-uses module)))
+           (not (eq? module the-root-module)))
+      ;; Import the default set of bindings (from the SCM module) in MODULE.
+      (module-use! module the-scm-module)))
+
+(define (version-matches? version-ref target)
+  (define (any pred lst)
+    (and (not (null? lst)) (or (pred (car lst)) (any pred (cdr lst)))))
+  (define (every pred lst) 
+    (or (null? lst) (and (pred (car lst)) (every pred (cdr lst)))))
+  (define (sub-versions-match? v-refs t)
+    (define (sub-version-matches? v-ref t)
+      (define (curried-sub-version-matches? v)
+        (sub-version-matches? v t))
+      (cond ((number? v-ref) (eqv? v-ref t))
+            ((list? v-ref)
+             (let ((cv (car v-ref)))
+               (cond ((eq? cv '>=) (>= t (cadr v-ref)))
+                     ((eq? cv '<=) (<= t (cadr v-ref)))
+                     ((eq? cv 'and) 
+                      (every curried-sub-version-matches? (cdr v-ref)))
+                     ((eq? cv 'or)
+                      (any curried-sub-version-matches? (cdr v-ref)))
+                     ((eq? cv 'not) (not (sub-version-matches? (cadr v-ref) t)))
+                     (else (error "Incompatible sub-version reference" cv)))))
+            (else (error "Incompatible sub-version reference" v-ref))))
+    (or (null? v-refs)
+        (and (not (null? t))
+             (sub-version-matches? (car v-refs) (car t))
+             (sub-versions-match? (cdr v-refs) (cdr t)))))
+  (define (curried-version-matches? v)
+    (version-matches? v target))
+  (or (null? version-ref)
+      (let ((cv (car version-ref)))
+        (cond ((eq? cv 'and) (every curried-version-matches? (cdr version-ref)))
+              ((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
+              ((eq? cv 'not) (not (version-matches? (cadr version-ref) target)))
+              (else (sub-versions-match? version-ref target))))))
+
+(define (find-versioned-module dir-hint name version-ref roots)
+  (define (subdir-pair-less pair1 pair2)
+    (define (numlist-less lst1 lst2)
+      (or (null? lst2) 
+          (and (not (null? lst1))
+               (cond ((> (car lst1) (car lst2)) #t)
+                     ((< (car lst1) (car lst2)) #f)
+                     (else (numlist-less (cdr lst1) (cdr lst2)))))))
+    (not (numlist-less (car pair2) (car pair1))))
+  (define (match-version-and-file pair)
+    (and (version-matches? version-ref (car pair))
+         (let ((filenames                            
+                (filter (lambda (file)
+                          (let ((s (false-if-exception (stat file))))
+                            (and s (eq? (stat:type s) 'regular))))
+                        (map (lambda (ext)
+                               (string-append (cdr pair) name ext))
+                             %load-extensions))))
+           (and (not (null? filenames))
+                (cons (car pair) (car filenames))))))
+    
+  (define (match-version-recursive root-pairs leaf-pairs)
+    (define (filter-subdirs root-pairs ret)
+      (define (filter-subdir root-pair dstrm subdir-pairs)
+        (let ((entry (readdir dstrm)))
+          (if (eof-object? entry)
+              subdir-pairs
+              (let* ((subdir (string-append (cdr root-pair) entry))
+                     (num (string->number entry))
+                     (num (and num (exact? num) (append (car root-pair) 
+                                                        (list num)))))
+                (if (and num (eq? (stat:type (stat subdir)) 'directory))
+                    (filter-subdir
+                     root-pair dstrm (cons (cons num (string-append subdir "/"))
+                                           subdir-pairs))
+                    (filter-subdir root-pair dstrm subdir-pairs))))))
+      
+      (or (and (null? root-pairs) ret)
+          (let* ((rp (car root-pairs))
+                 (dstrm (false-if-exception (opendir (cdr rp)))))
+            (if dstrm
+                (let ((subdir-pairs (filter-subdir rp dstrm '())))
+                  (closedir dstrm)
+                  (filter-subdirs (cdr root-pairs) 
+                                  (or (and (null? subdir-pairs) ret)
+                                      (append ret subdir-pairs))))
+                (filter-subdirs (cdr root-pairs) ret)))))
+    
+    (or (and (null? root-pairs) leaf-pairs)
+        (let ((matching-subdir-pairs (filter-subdirs root-pairs '())))
+          (match-version-recursive
+           matching-subdir-pairs
+           (append leaf-pairs (filter pair? (map match-version-and-file 
+                                                 matching-subdir-pairs)))))))
+  (define (make-root-pair root)
+    (cons '() (string-append root "/" dir-hint)))
+
+  (let* ((root-pairs (map make-root-pair roots))
+         (matches (if (null? version-ref) 
+                      (filter pair? (map match-version-and-file root-pairs))
+                      '()))
+         (matches (append matches (match-version-recursive root-pairs '()))))
+    (and (null? matches) (error "No matching modules found."))
+    (cdar (sort matches subdir-pair-less))))
+
+(define (make-fresh-user-module)
+  (let ((m (make-module)))
+    (beautify-user-module! m)
+    m))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
+(define resolve-module
+  (let ((root (make-module)))
+    (set-module-name! root '())
+    ;; Define the-root-module as '(guile).
+    (module-define-submodule! root 'guile the-root-module)
+
+    (lambda* (name #:optional (autoload #t) (version #f))
+      (let ((already (nested-ref-module root name)))
+        (cond
+         ((and already
+               (or (not autoload) (module-public-interface already)))
+          ;; A hit, a palpable hit.
+          (if (and version 
+                   (not (version-matches? version (module-version already))))
+              (error "incompatible module version already loaded" name))
+          already)
+         (autoload
+          ;; Try to autoload the module, and recurse.
+          (try-load-module name version)
+          (resolve-module name #f))
+         (else
+          ;; No module found (or if one was, it had no public interface), and
+          ;; we're not autoloading. Here's the weird semantics: we ensure
+          ;; there's an empty module.
+          (or already (make-modules-in root name))))))))
+
 
-(define (try-load-module name)
-  (try-module-autoload name))
+(define (try-load-module name version)
+  (try-module-autoload name version))
 
 (define (purify-module! module)
   "Removes bindings in MODULE which are inherited from the (guile) module."
   (let ((use-list (module-uses module)))
     (if (and (pair? use-list)
-	     (eq? (car (last-pair use-list)) the-scm-module))
-	(set-module-uses! module (reverse (cdr (reverse use-list)))))))
+             (eq? (car (last-pair use-list)) the-scm-module))
+        (set-module-uses! module (reverse (cdr (reverse use-list)))))))
 
 ;; Return a module that is an interface to the module designated by
 ;; NAME.
@@ -2114,61 +2481,52 @@
 ;; or its public interface is not available.  Signal "no binding"
 ;; error if selected binding does not exist in the used module.
 ;;
-(define (resolve-interface name . args)
-
-  (define (get-keyword-arg args kw def)
-    (cond ((memq kw args)
-	   => (lambda (kw-arg)
-		(if (null? (cdr kw-arg))
-		    (error "keyword without value: " kw))
-		(cadr kw-arg)))
-	  (else
-	   def)))
-
-  (let* ((select (get-keyword-arg args #:select #f))
-	 (hide (get-keyword-arg args #:hide '()))
-	 (renamer (or (get-keyword-arg args #:renamer #f)
-		      (let ((prefix (get-keyword-arg args #:prefix #f)))
-			(and prefix (symbol-prefix-proc prefix)))
-		      identity))
-         (module (resolve-module name))
+(define* (resolve-interface name #:key
+                            (select #f)
+                            (hide '())
+                            (prefix #f)
+                            (renamer (if prefix
+                                         (symbol-prefix-proc prefix)
+                                         identity))
+                            version)
+  (let* ((module (resolve-module name #t version))
          (public-i (and module (module-public-interface module))))
     (and (or (not module) (not public-i))
          (error "no code for module" name))
     (if (and (not select) (null? hide) (eq? renamer identity))
         public-i
         (let ((selection (or select (module-map (lambda (sym var) sym)
-						public-i)))
+                                                public-i)))
               (custom-i (make-module 31)))
           (set-module-kind! custom-i 'custom-interface)
-	  (set-module-name! custom-i name)
-	  ;; XXX - should use a lazy binder so that changes to the
-	  ;; used module are picked up automatically.
-	  (for-each (lambda (bspec)
-		      (let* ((direct? (symbol? bspec))
-			     (orig (if direct? bspec (car bspec)))
-			     (seen (if direct? bspec (cdr bspec)))
-			     (var (or (module-local-variable public-i orig)
-				      (module-local-variable module orig)
-				      (error
-				       ;; fixme: format manually for now
-				       (simple-format
-					#f "no binding `~A' in module ~A"
-					orig name)))))
-			(if (memq orig hide)
-			    (set! hide (delq! orig hide))
-			    (module-add! custom-i
-					 (renamer seen)
-					 var))))
-		    selection)
-	  ;; Check that we are not hiding bindings which don't exist
-	  (for-each (lambda (binding)
-		      (if (not (module-local-variable public-i binding))
-			  (error
-			   (simple-format
-			    #f "no binding `~A' to hide in module ~A"
-			    binding name))))
-		    hide)
+          (set-module-name! custom-i name)
+          ;; XXX - should use a lazy binder so that changes to the
+          ;; used module are picked up automatically.
+          (for-each (lambda (bspec)
+                      (let* ((direct? (symbol? bspec))
+                             (orig (if direct? bspec (car bspec)))
+                             (seen (if direct? bspec (cdr bspec)))
+                             (var (or (module-local-variable public-i orig)
+                                      (module-local-variable module orig)
+                                      (error
+                                       ;; fixme: format manually for now
+                                       (simple-format
+                                        #f "no binding `~A' in module ~A"
+                                        orig name)))))
+                        (if (memq orig hide)
+                            (set! hide (delq! orig hide))
+                            (module-add! custom-i
+                                         (renamer seen)
+                                         var))))
+                    selection)
+          ;; Check that we are not hiding bindings which don't exist
+          (for-each (lambda (binding)
+                      (if (not (module-local-variable public-i binding))
+                          (error
+                           (simple-format
+                            #f "no binding `~A' to hide in module ~A"
+                            binding name))))
+                    hide)
           custom-i))))
 
 (define (symbol-prefix-proc prefix)
@@ -2252,6 +2610,14 @@
              (purify-module! module)
              (loop (cdr kws) reversed-interfaces exports re-exports
                    replacements autoloads))
+            ((#:version)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (let ((version (cadr kws)))
+               (set-module-version! module version)
+               (set-module-version! (module-public-interface module) version))
+             (loop (cddr kws) reversed-interfaces exports re-exports
+                   replacements autoloads))
             ((#:duplicates)
              (if (not (pair? (cdr kws)))
                  (unrecognized kws))
@@ -2287,6 +2653,16 @@
                    re-exports
                    (append (cadr kws) replacements)
                    autoloads))
+            ((#:filename)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (set-module-filename! module (cadr kws))
+             (loop (cddr kws)
+                   reversed-interfaces
+                   exports
+                   re-exports
+                   replacements
+                   autoloads))
             (else
              (unrecognized kws)))))
     (run-hook module-defined-hook module)
@@ -2304,18 +2680,19 @@
 
 (define (make-autoload-interface module name bindings)
   (let ((b (lambda (a sym definep)
-	     (and (memq sym bindings)
-		  (let ((i (module-public-interface (resolve-module name))))
-		    (if (not i)
-			(error "missing interface for module" name))
-		    (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))))))
+             (and (memq sym bindings)
+                  (let ((i (module-public-interface (resolve-module name))))
+                    (if (not i)
+                        (error "missing interface for module" name))
+                    (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
-                        (make-hash-table 0) '() (make-weak-value-hash-table 31))))
+                        (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
+                        (make-hash-table 0) #f #f #f)))
 
 (define (module-autoload! module . args)
   "Have @var{module} automatically load the module named @var{name} when one
@@ -2345,28 +2722,30 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; This function is called from "modules.c".  If you change it, be
 ;; sure to update "modules.c" as well.
 
-(define (try-module-autoload module-name)
+(define* (try-module-autoload module-name #:optional version)
   (let* ((reverse-name (reverse module-name))
-	 (name (symbol->string (car reverse-name)))
-	 (dir-hint-module-name (reverse (cdr reverse-name)))
-	 (dir-hint (apply string-append
-			  (map (lambda (elt)
-				 (string-append (symbol->string elt) "/"))
-			       dir-hint-module-name))))
+         (name (symbol->string (car reverse-name)))
+         (dir-hint-module-name (reverse (cdr reverse-name)))
+         (dir-hint (apply string-append
+                          (map (lambda (elt)
+                                 (string-append (symbol->string elt) "/"))
+                               dir-hint-module-name))))
     (resolve-module dir-hint-module-name #f)
     (and (not (autoload-done-or-in-progress? dir-hint name))
-	 (let ((didit #f))
-	   (dynamic-wind
-	    (lambda () (autoload-in-progress! dir-hint name))
-	    (lambda ()
-	      (with-fluid* current-reader #f
-                (lambda ()
-                  (save-module-excursion
-                   (lambda () 
-                     (primitive-load-path (in-vicinity dir-hint name) #f)
-                     (set! didit #t))))))
-	    (lambda () (set-autoloaded! dir-hint name didit)))
-	   didit))))
+         (let ((didit #f))
+           (dynamic-wind
+            (lambda () (autoload-in-progress! dir-hint name))
+            (lambda ()
+              (with-fluids ((current-reader #f))
+                (save-module-excursion
+                 (lambda () 
+                   (if version
+                       (load (find-versioned-module
+                              dir-hint name version %load-path))
+                       (primitive-load-path (in-vicinity dir-hint name) #f))
+                   (set! didit #t)))))
+            (lambda () (set-autoloaded! dir-hint name didit)))
+           didit))))
 
 
 
@@ -2378,27 +2757,27 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (autoload-done-or-in-progress? p m)
   (let ((n (cons p m)))
     (->bool (or (member n autoloads-done)
-		(member n autoloads-in-progress)))))
+                (member n autoloads-in-progress)))))
 
 (define (autoload-done! p m)
   (let ((n (cons p m)))
     (set! autoloads-in-progress
-	  (delete! n autoloads-in-progress))
+          (delete! n autoloads-in-progress))
     (or (member n autoloads-done)
-	(set! autoloads-done (cons n autoloads-done)))))
+        (set! autoloads-done (cons n autoloads-done)))))
 
 (define (autoload-in-progress! p m)
   (let ((n (cons p m)))
     (set! autoloads-done
-	  (delete! n autoloads-done))
+          (delete! n autoloads-done))
     (set! autoloads-in-progress (cons n autoloads-in-progress))))
 
 (define (set-autoloaded! p m done?)
   (if done?
       (autoload-done! p m)
       (let ((n (cons p m)))
-	(set! autoloads-done (delete! n autoloads-done))
-	(set! autoloads-in-progress (delete! n autoloads-in-progress)))))
+        (set! autoloads-done (delete! n autoloads-done))
+        (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
 
 
 
@@ -2407,17 +2786,17 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (defmacro define-option-interface (option-group)
   (let* ((option-name 'car)
-	 (option-value 'cadr)
-	 (option-documentation 'caddr)
+         (option-value 'cadr)
+         (option-documentation 'caddr)
 
-	 ;; Below follow the macros defining the run-time option interfaces.
+         ;; Below follow the macros defining the run-time option interfaces.
 
-	 (make-options (lambda (interface)
-			 `(lambda args
-			    (cond ((null? args) (,interface))
-				  ((list? (car args))
-				   (,interface (car args)) (,interface))
-				  (else (for-each
+         (make-options (lambda (interface)
+                         `(lambda args
+                            (cond ((null? args) (,interface))
+                                  ((list? (car args))
+                                   (,interface (car args)) (,interface))
+                                  (else (for-each
                                          (lambda (option)
                                            (display (,option-name option))
                                            (if (< (string-length
@@ -2431,19 +2810,19 @@ module '(ice-9 q) '(make-q q-length))}."
                                            (newline))
                                          (,interface #t)))))))
 
-	 (make-enable (lambda (interface)
-			`(lambda flags
-			   (,interface (append flags (,interface)))
-			   (,interface))))
-
-	 (make-disable (lambda (interface)
-			 `(lambda flags
-			    (let ((options (,interface)))
-			      (for-each (lambda (flag)
-					  (set! options (delq! flag options)))
-					flags)
-			      (,interface options)
-			      (,interface))))))
+         (make-enable (lambda (interface)
+                        `(lambda flags
+                           (,interface (append flags (,interface)))
+                           (,interface))))
+
+         (make-disable (lambda (interface)
+                         `(lambda flags
+                            (let ((options (,interface)))
+                              (for-each (lambda (flag)
+                                          (set! options (delq! flag options)))
+                                        flags)
+                              (,interface options)
+                              (,interface))))))
     (let* ((interface (car option-group))
            (options/enable/disable (cadr option-group)))
       `(begin
@@ -2512,7 +2891,8 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (set-repl-prompt! v) (set! scm-repl-prompt v))
 
 (define (default-pre-unwind-handler key . args)
-  (save-stack 1)
+  ;; Narrow by two more frames: this one, and the throw handler.
+  (save-stack 2)
   (apply throw key args))
 
 (begin-deprecated
@@ -2526,113 +2906,27 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (set-batch-mode?! arg) #t)
 (define (batch-mode?) #t)
 
-(define (error-catching-loop thunk)
-  (let ((status #f)
-	(interactive #t))
-    (define (loop first)
-      (let ((next
-	     (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)))))
-
-		    (lambda (key . args)
-		      (case key
-			((quit)
-			 (set! status args)
-			 #f)
-
-			((switch-repl)
-			 (apply throw 'switch-repl args))
-
-			((abort)
-			 ;; This is one of the closures that require
-			 ;; (set! first #f) above
-			 ;;
-			 (lambda ()
-			   (run-hook abort-hook)
-			   (force-output (current-output-port))
-			   (display "ABORT: "  (current-error-port))
-			   (write args (current-error-port))
-			   (newline (current-error-port))
-			   (if interactive
-			       (begin
-				 (if (and
-				      (not has-shown-debugger-hint?)
-				      (not (memq 'backtrace
-						 (debug-options-interface)))
-				      (stack? (fluid-ref the-last-stack)))
-				     (begin
-				       (newline (current-error-port))
-				       (display
-					"Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
-					(current-error-port))
-				       (set! has-shown-debugger-hint? #t)))
-				 (force-output (current-error-port)))
-			       (begin
-				 (primitive-exit 1)))
-			   (set! stack-saved? #f)))
-
-			(else
-			 ;; This is the other cons-leak closure...
-			 (lambda ()
-			   (cond ((= (length args) 4)
-				  (apply handle-system-error key args))
-				 (else
-				  (apply bad-throw key args)))))))
-
-                    default-pre-unwind-handler)))
-
-	(if next (loop next) status)))
-    (set! set-batch-mode?! (lambda (arg)
-			     (cond (arg
-				    (set! interactive #f)
-				    (restore-signals))
-				   (#t
-				    (error "sorry, not implemented")))))
-    (set! batch-mode? (lambda () (not interactive)))
-    (call-with-blocked-asyncs
-     (lambda () (loop (lambda () #t))))))
-
 ;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
 (define before-signal-stack (make-fluid))
+;; FIXME: stack-saved? is broken in the presence of threads.
 (define stack-saved? #f)
 
 (define (save-stack . narrowing)
-  (or stack-saved?
-      (cond ((not (memq 'debug (debug-options-interface)))
-	     (fluid-set! the-last-stack #f)
-	     (set! stack-saved? #t))
-	    (else
-	     (fluid-set!
-	      the-last-stack
-	      (case (stack-id #t)
-		((repl-stack)
-		 (apply make-stack #t save-stack primitive-eval #t 0 narrowing))
-		((load-stack)
-		 (apply make-stack #t save-stack 0 #t 0 narrowing))
-		((tk-stack)
-		 (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
-		((#t)
-		 (apply make-stack #t save-stack 0 1 narrowing))
-		(else
-		 (let ((id (stack-id #t)))
-		   (and (procedure? id)
-			(apply make-stack #t save-stack id #t 0 narrowing))))))
-	     (set! stack-saved? #t)))))
+  (if (not stack-saved?)
+      (begin
+        (let ((stacks (fluid-ref %stacks)))
+          (fluid-set! the-last-stack
+                      ;; (make-stack obj inner outer inner outer ...)
+                      ;;
+                      ;; In this case, cut away the make-stack frame, the
+                      ;; save-stack frame, and then narrow as specified by the
+                      ;; user, delimited by the nearest start-stack invocation,
+                      ;; if any.
+                      (apply make-stack #t
+                             2
+                             (if (pair? stacks) (cdar stacks) 0)
+                             narrowing)))
+        (set! stack-saved? #t))))
 
 (define before-error-hook (make-hook))
 (define after-error-hook (make-hook))
@@ -2644,18 +2938,18 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (handle-system-error key . args)
   (let ((cep (current-error-port)))
     (cond ((not (stack? (fluid-ref the-last-stack))))
-	  ((memq 'backtrace (debug-options-interface))
-	   (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))))
+          ((memq 'backtrace (debug-options-interface))
+           (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)
@@ -2667,30 +2961,6 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define exit quit)
 
-;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
-
-;; Replaced by C code:
-;;(define (backtrace)
-;;  (if (fluid-ref the-last-stack)
-;;      (begin
-;;	(newline)
-;;	(display-backtrace (fluid-ref the-last-stack) (current-output-port))
-;;	(newline)
-;;	(if (and (not has-shown-backtrace-hint?)
-;;		 (not (memq 'backtrace (debug-options-interface))))
-;;	    (begin
-;;	      (display
-;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
-;;automatically if an error occurs in the future.\n")
-;;	      (set! has-shown-backtrace-hint? #t))))
-;;      (display "No backtrace available.\n")))
-
-(define (error-catching-repl r e p)
-  (error-catching-loop
-   (lambda ()
-     (call-with-values (lambda () (e (r)))
-       (lambda the-values (for-each p the-values))))))
-
 (define (gc-run-time)
   (cdr (assq 'gc-time-taken (gc-stats))))
 
@@ -2704,126 +2974,12 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; The default repl-reader function.  We may override this if we've
 ;;; the readline library.
 (define repl-reader
-  (lambda (prompt)
-    (display (if (string? prompt) prompt (prompt)))
+  (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
+    (if (not (char-ready?))
+        (display (if (string? prompt) prompt (prompt))))
     (force-output)
     (run-hook before-read-hook)
-    ((or (fluid-ref current-reader) read) (current-input-port))))
-
-(define (scm-style-repl)
-
-  (letrec (
-	   (start-gc-rt #f)
-	   (start-rt #f)
-	   (repl-report-start-timing (lambda ()
-				       (set! start-gc-rt (gc-run-time))
-				       (set! start-rt (get-internal-run-time))))
-	   (repl-report (lambda ()
-			  (display ";;; ")
-			  (display (inexact->exact
-				    (* 1000 (/ (- (get-internal-run-time) start-rt)
-					       internal-time-units-per-second))))
-			  (display "  msec  (")
-			  (display  (inexact->exact
-				     (* 1000 (/ (- (gc-run-time) start-gc-rt)
-						internal-time-units-per-second))))
-			  (display " msec in gc)\n")))
-
-	   (consume-trailing-whitespace
-	    (lambda ()
-	      (let ((ch (peek-char)))
-		(cond
-		 ((eof-object? ch))
-		 ((or (char=? ch #\space) (char=? ch #\tab))
-		  (read-char)
-		  (consume-trailing-whitespace))
-		 ((char=? ch #\newline)
-		  (read-char))))))
-	   (-read (lambda ()
-		    (let ((val
-			   (let ((prompt (cond ((string? scm-repl-prompt)
-						scm-repl-prompt)
-					       ((thunk? scm-repl-prompt)
-						(scm-repl-prompt))
-					       (scm-repl-prompt "> ")
-					       (else ""))))
-			     (repl-reader prompt))))
-
-		      ;; As described in R4RS, the READ procedure updates the
-		      ;; port to point to the first character past the end of
-		      ;; the external representation of the object.  This
-		      ;; means that it doesn't consume the newline typically
-		      ;; found after an expression.  This means that, when
-		      ;; debugging Guile with GDB, GDB gets the newline, which
-		      ;; it often interprets as a "continue" command, making
-		      ;; breakpoints kind of useless.  So, consume any
-		      ;; trailing newline here, as well as any whitespace
-		      ;; before it.
-		      ;; But not if EOF, for control-D.
-		      (if (not (eof-object? val))
-			  (consume-trailing-whitespace))
-		      (run-hook after-read-hook)
-		      (if (eof-object? val)
-			  (begin
-			    (repl-report-start-timing)
-			    (if scm-repl-verbose
-				(begin
-				  (newline)
-				  (display ";;; EOF -- quitting")
-				  (newline)))
-			    (quit 0)))
-		      val)))
-
-	   (-eval (lambda (sourc)
-		    (repl-report-start-timing)
-		    (run-hook before-eval-hook sourc)
-		    (let ((val (start-stack 'repl-stack
-					    ;; If you change this procedure
-					    ;; (primitive-eval), please also
-					    ;; modify the repl-stack case in
-					    ;; save-stack so that stack cutting
-					    ;; continues to work.
-					    (primitive-eval sourc))))
-		      (run-hook after-eval-hook sourc)
-		      val)))
-
-
-	   (-print (let ((maybe-print (lambda (result)
-					(if (or scm-repl-print-unspecified
-						(not (unspecified? result)))
-					    (begin
-					      (write result)
-					      (newline))))))
-		     (lambda (result)
-		       (if (not scm-repl-silent)
-			   (begin
-			     (run-hook before-print-hook result)
-			     (maybe-print result)
-			     (run-hook after-print-hook result)
-			     (if scm-repl-verbose
-				 (repl-report))
-			     (force-output))))))
-
-	   (-quit (lambda (args)
-		    (if scm-repl-verbose
-			(begin
-			  (display ";;; QUIT executed, repl exitting")
-			  (newline)
-			  (repl-report)))
-		    args))
-
-	   (-abort (lambda ()
-		     (if scm-repl-verbose
-			 (begin
-			   (display ";;; ABORT executed.")
-			   (newline)
-			   (repl-report)))
-		     (repl -read -eval -print))))
-
-    (let ((status (error-catching-repl -read
-				       -eval
-				       -print)))
-      (-quit status))))
+    ((or reader read) (current-input-port))))
 
 
 
@@ -2851,24 +3007,6 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
-;;; {with-fluids}
-;;;
-
-;; with-fluids is a convenience wrapper for the builtin procedure
-;; `with-fluids*'.  The syntax is just like `let':
-;;
-;;  (with-fluids ((fluid val)
-;;                ...)
-;;     body)
-
-(defmacro with-fluids (bindings . body)
-  (let ((fluids (map car bindings))
-	(values (map cadr bindings)))
-    (if (and (= (length fluids) 1) (= (length values) 1))
-	`(with-fluid* ,(car fluids) ,(car values) (lambda () ,@body))
-	`(with-fluids* (list ,@fluids) (list ,@values)
-		       (lambda () ,@body)))))
-
 ;;; {While}
 ;;;
 ;;; with `continue' and `break'.
@@ -2911,75 +3049,85 @@ module '(ice-9 q) '(make-q q-length))}."
  (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)
-	       (memq key spec))
-	   => (lambda (rest)
-		(if quote?
-		    (list key (list 'quote (cadr rest)))
-		    (list key (cadr rest)))))
-	  (else
-	   '())))
-  (define (map-apply func list)
-    (map (lambda (args) (apply func args)) list))
-  (define keys
-    ;; sym     key      quote?
-    '((:select #:select #t)
-      (:hide   #:hide	#t)
-      (:prefix #:prefix #t)
-      (:renamer #:renamer #f)))
-  (if (not (pair? (car spec)))
-      `(',spec)
-      `(',(car spec)
-	,@(apply append (map-apply make-keyarg keys)))))
-
 (define (keyword-like-symbol->keyword sym)
   (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
 
-(define (compile-define-module-args args)
-  ;; Just quote everything except #:use-module and #:use-syntax.  We
-  ;; need to know about all arguments regardless since we want to turn
-  ;; symbols that look like keywords into real keywords, and the
-  ;; keyword args in a define-module form are not regular
-  ;; (i.e. no-backtrace doesn't take a value).
-  (let loop ((compiled-args `((quote ,(car args))))
-	     (args (cdr args)))
-    (cond ((null? args)
-	   (reverse! compiled-args))
-	  ;; symbol in keyword position
-	  ((symbol? (car args))
-	   (loop compiled-args
-		 (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
-	  ((memq (car args) '(#:no-backtrace #:pure))
-	   (loop (cons (car args) compiled-args)
-		 (cdr args)))
-	  ((null? (cdr args))
-	   (error "keyword without value:" (car args)))
-	  ((memq (car args) '(#:use-module #:use-syntax))
-	   (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
-			(car args)
-			compiled-args)
-		 (cddr args)))
-	  ((eq? (car args) #:autoload)
-	   (loop (cons* `(quote ,(caddr args))
-			`(quote ,(cadr args))
-			(car args)
-			compiled-args)
-		 (cdddr args)))
-	  (else
-	   (loop (cons* `(quote ,(cadr args))
-			(car args)
-			compiled-args)
-		 (cddr args))))))
-
-(defmacro define-module args
-  `(eval-when
-    (eval load compile)
-    (let ((m (process-define-module
-              (list ,@(compile-define-module-args args)))))
-      (set-current-module m)
-      m)))
+;; FIXME: we really need to clean up the guts of the module system.
+;; We can compile to something better than process-define-module.
+(define-syntax define-module
+  (lambda (x)
+    (define (keyword-like? stx)
+      (let ((dat (syntax->datum stx)))
+        (and (symbol? dat)
+             (eqv? (string-ref (symbol->string dat) 0) #\:))))
+    (define (->keyword sym)
+      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+    
+    (define (quotify-iface args)
+      (let loop ((in args) (out '()))
+        (syntax-case in ()
+          (() (reverse! out))
+          ;; The user wanted #:foo, but wrote :foo. Fix it.
+          ((sym . in) (keyword-like? #'sym)
+           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+          ((kw . in) (not (keyword? (syntax->datum #'kw)))
+           (syntax-violation 'define-module "expected keyword arg" x #'kw))
+          ((#:renamer renamer . in)
+           (loop #'in (cons* #'renamer #:renamer out)))
+          ((kw val . in)
+           (loop #'in (cons* #''val #'kw out))))))
+
+    (define (quotify args)
+      ;; Just quote everything except #:use-module and #:use-syntax.  We
+      ;; need to know about all arguments regardless since we want to turn
+      ;; symbols that look like keywords into real keywords, and the
+      ;; keyword args in a define-module form are not regular
+      ;; (i.e. no-backtrace doesn't take a value).
+      (let loop ((in args) (out '()))
+        (syntax-case in ()
+          (() (reverse! out))
+          ;; The user wanted #:foo, but wrote :foo. Fix it.
+          ((sym . in) (keyword-like? #'sym)
+           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+          ((kw . in) (not (keyword? (syntax->datum #'kw)))
+           (syntax-violation 'define-module "expected keyword arg" x #'kw))
+          ((#:no-backtrace . in)
+           (loop #'in (cons #:no-backtrace out)))
+          ((#:pure . in)
+           (loop #'in (cons #:pure out)))
+          ((kw)
+           (syntax-violation 'define-module "keyword arg without value" x #'kw))
+          ((use-module (name name* ...) . in)
+           (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
+                (and-map symbol? (syntax->datum #'(name name* ...))))
+           (loop #'in
+                 (cons* #''((name name* ...))
+                        #'use-module
+                        out)))
+          ((use-module ((name name* ...) arg ...) . in)
+           (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
+                (and-map symbol? (syntax->datum #'(name name* ...))))
+           (loop #'in
+                 (cons* #`(list '(name name* ...) #,@(quotify-iface #'(arg ...)))
+                        #'use-module
+                        out)))
+          ((#:autoload name bindings . in)
+           (loop #'in (cons* #''bindings #''name #:autoload out)))
+          ((kw val . in)
+           (loop #'in (cons* #''val #'kw out))))))
+    
+    (syntax-case x ()
+      ((_ (name name* ...) arg ...)
+       (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+         #'(eval-when (eval load compile expand)
+             (let ((m (process-define-module
+                       (list '(name name* ...)
+                             #:filename (assq-ref
+                                         (or (current-source-location) '())
+                                         'filename)
+                             quoted-arg ...))))
+               (set-current-module m)
+               m)))))))
 
 ;; The guts of the use-modules macro.  Add the interfaces of the named
 ;; modules to the use-list of the current module, in order.
@@ -2989,29 +3137,66 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define (process-use-modules module-interface-args)
   (let ((interfaces (map (lambda (mif-args)
-			   (or (apply resolve-interface mif-args)
-			       (error "no such module" mif-args)))
-			 module-interface-args)))
+                           (or (apply resolve-interface mif-args)
+                               (error "no such module" mif-args)))
+                         module-interface-args)))
     (call-with-deferred-observers
      (lambda ()
        (module-use-interfaces! (current-module) interfaces)))))
 
-(defmacro use-modules modules
-  `(eval-when
-    (eval load compile)
-    (process-use-modules
-     (list ,@(map (lambda (m)
-                    `(list ,@(compile-interface-spec m)))
-                  modules)))
-    *unspecified*))
-
-(defmacro use-syntax (spec)
-  `(eval-when
-    (eval load compile)
-    (issue-deprecation-warning
-     "`use-syntax' is deprecated. Please contact guile-devel for more info.")
-    (process-use-modules (list (list ,@(compile-interface-spec spec))))
-    *unspecified*))
+(define-syntax use-modules
+  (lambda (x)
+    (define (keyword-like? stx)
+      (let ((dat (syntax->datum stx)))
+        (and (symbol? dat)
+             (eqv? (string-ref (symbol->string dat) 0) #\:))))
+    (define (->keyword sym)
+      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+    
+    (define (quotify-iface args)
+      (let loop ((in args) (out '()))
+        (syntax-case in ()
+          (() (reverse! out))
+          ;; The user wanted #:foo, but wrote :foo. Fix it.
+          ((sym . in) (keyword-like? #'sym)
+           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
+          ((kw . in) (not (keyword? (syntax->datum #'kw)))
+           (syntax-violation 'define-module "expected keyword arg" x #'kw))
+          ((#:renamer renamer . in)
+           (loop #'in (cons* #'renamer #:renamer out)))
+          ((kw val . in)
+           (loop #'in (cons* #''val #'kw out))))))
+
+    (define (quotify specs)
+      (let lp ((in specs) (out '()))
+        (syntax-case in ()
+          (() (reverse out))
+          (((name name* ...) . in)
+           (and-map symbol? (syntax->datum #'(name name* ...)))
+           (lp #'in (cons #''((name name* ...)) out)))
+          ((((name name* ...) arg ...) . in)
+           (and-map symbol? (syntax->datum #'(name name* ...)))
+           (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
+             (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
+                            out)))))))
+    
+    (syntax-case x ()
+      ((_ spec ...)
+       (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
+         #'(eval-when (eval load compile expand)
+             (process-use-modules (list quoted-args ...))
+             *unspecified*))))))
+
+(define-syntax use-syntax
+  (syntax-rules ()
+    ((_ spec ...)
+     (begin
+       (eval-when (eval load compile expand)
+         (issue-deprecation-warning
+          "`use-syntax' is deprecated. Please contact guile-devel for more info."))
+       (use-modules spec ...)))))
+
+(include-from-path "ice-9/r6rs-libraries")
 
 (define-syntax define-private
   (syntax-rules ()
@@ -3034,6 +3219,13 @@ module '(ice-9 q) '(make-q q-length))}."
        (defmacro name args . body)
        (export-syntax name)))))
 
+;; And now for the most important macro.
+(define-syntax λ
+  (syntax-rules ()
+    ((_ formals body ...)
+     (lambda formals body ...))))
+
+
 ;; Export a local variable
 
 ;; This function is called from "modules.c".  If you change it, be
@@ -3042,47 +3234,77 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (module-export! m names)
   (let ((public-i (module-public-interface m)))
     (for-each (lambda (name)
-		(let ((var (module-ensure-local-variable! m name)))
-		  (module-add! public-i name var)))
-	      names)))
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-ensure-local-variable! m internal-name)))
+                  (module-add! public-i external-name var)))
+              names)))
 
 (define (module-replace! m names)
   (let ((public-i (module-public-interface m)))
     (for-each (lambda (name)
-		(let ((var (module-ensure-local-variable! m name)))
-		  (set-object-property! var 'replace #t)
-		  (module-add! public-i name var)))
-	      names)))
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-ensure-local-variable! m internal-name)))
+                  (set-object-property! var 'replace #t)
+                  (module-add! public-i external-name var)))
+              names)))
+
+;; Export all local variables from a module
+;;
+(define (module-export-all! mod)
+  (define (fresh-interface!)
+    (let ((iface (make-module)))
+      (set-module-name! iface (module-name mod))
+      ;; for guile 2: (set-module-version! iface (module-version mod))
+      (set-module-kind! iface 'interface)
+      (set-module-public-interface! mod iface)
+      iface))
+  (let ((iface (or (module-public-interface mod)
+                   (fresh-interface!))))
+    (set-module-obarray! iface (module-obarray mod))))
 
 ;; Re-export a imported variable
 ;;
 (define (module-re-export! m names)
   (let ((public-i (module-public-interface m)))
     (for-each (lambda (name)
-		(let ((var (module-variable m name)))
-		  (cond ((not var)
-			 (error "Undefined variable:" name))
-			((eq? var (module-local-variable m name))
-			 (error "re-exporting local variable:" name))
-			(else
-			 (module-add! public-i name var)))))
-	      names)))
-
-(defmacro export names
-  `(call-with-deferred-observers
-    (lambda ()
-      (module-export! (current-module) ',names))))
+                (let* ((internal-name (if (pair? name) (car name) name))
+                       (external-name (if (pair? name) (cdr name) name))
+                       (var (module-variable m internal-name)))
+                  (cond ((not var)
+                         (error "Undefined variable:" internal-name))
+                        ((eq? var (module-local-variable m internal-name))
+                         (error "re-exporting local variable:" internal-name))
+                        (else
+                         (module-add! public-i external-name var)))))
+              names)))
 
-(defmacro re-export names
-  `(call-with-deferred-observers
-    (lambda ()
-      (module-re-export! (current-module) ',names))))
+(define-syntax export
+  (syntax-rules ()
+    ((_ name ...)
+     (eval-when (eval load compile expand)
+       (call-with-deferred-observers
+        (lambda ()
+          (module-export! (current-module) '(name ...))))))))
 
-(defmacro export-syntax names
-  `(export ,@names))
+(define-syntax re-export
+  (syntax-rules ()
+    ((_ name ...)
+     (eval-when (eval load compile expand)
+       (call-with-deferred-observers
+        (lambda ()
+          (module-re-export! (current-module) '(name ...))))))))
 
-(defmacro re-export-syntax names
-  `(re-export ,@names))
+(define-syntax export-syntax
+  (syntax-rules ()
+    ((_ name ...)
+     (export name ...))))
+
+(define-syntax re-export-syntax
+  (syntax-rules ()
+    ((_ name ...)
+     (re-export name ...))))
 
 (define load load-module)
 
@@ -3093,17 +3315,14 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define make-mutable-parameter
   (let ((make (lambda (fluid converter)
-		(lambda args
-		  (if (null? args)
-		      (fluid-ref fluid)
-		      (fluid-set! fluid (converter (car args))))))))
-    (lambda (init . converter)
-      (let ((fluid (make-fluid))
-	    (converter (if (null? converter)
-			   identity
-			   (car converter))))
-	(fluid-set! fluid (converter init))
-	(make fluid converter)))))
+                (lambda args
+                  (if (null? args)
+                      (fluid-ref fluid)
+                      (fluid-set! fluid (converter (car args))))))))
+    (lambda* (init #:optional (converter identity))
+      (let ((fluid (make-fluid)))
+        (fluid-set! fluid (converter init))
+        (make fluid converter)))))
 
 
 
@@ -3113,13 +3332,13 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; Duplicate handlers take the following arguments:
 ;;
 ;; module  importing module
-;; name	   conflicting name
-;; int1	   old interface where name occurs
-;; val1	   value of binding in old interface
-;; int2	   new interface where name occurs
-;; val2	   value of binding in new interface
-;; var	   previous resolution or #f
-;; val	   value of previous resolution
+;; name    conflicting name
+;; int1    old interface where name occurs
+;; val1    value of binding in old interface
+;; int2    new interface where name occurs
+;; val2    value of binding in new interface
+;; var     previous resolution or #f
+;; val     value of previous resolution
 ;;
 ;; A duplicate handler can take three alternative actions:
 ;;
@@ -3133,43 +3352,43 @@ module '(ice-9 q) '(make-q q-length))}."
     
     (define (check module name int1 val1 int2 val2 var val)
       (scm-error 'misc-error
-		 #f
-		 "~A: `~A' imported from both ~A and ~A"
-		 (list (module-name module)
-		       name
-		       (module-name int1)
-		       (module-name int2))
-		 #f))
+                 #f
+                 "~A: `~A' imported from both ~A and ~A"
+                 (list (module-name module)
+                       name
+                       (module-name int1)
+                       (module-name int2))
+                 #f))
     
     (define (warn module name int1 val1 int2 val2 var val)
       (format (current-error-port)
-	      "WARNING: ~A: `~A' imported from both ~A and ~A\n"
-	      (module-name module)
-	      name
-	      (module-name int1)
-	      (module-name int2))
+              "WARNING: ~A: `~A' imported from both ~A and ~A\n"
+              (module-name module)
+              name
+              (module-name int1)
+              (module-name int2))
       #f)
      
     (define (replace module name int1 val1 int2 val2 var val)
       (let ((old (or (and var (object-property var 'replace) var)
-		     (module-variable int1 name)))
-	    (new (module-variable int2 name)))
-	(if (object-property old 'replace)
-	    (and (or (eq? old new)
-		     (not (object-property new 'replace)))
-		 old)
-	    (and (object-property new 'replace)
-		 new))))
+                     (module-variable int1 name)))
+            (new (module-variable int2 name)))
+        (if (object-property old 'replace)
+            (and (or (eq? old new)
+                     (not (object-property new 'replace)))
+                 old)
+            (and (object-property new 'replace)
+                 new))))
     
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
-	   (begin
-	     (format (current-error-port)
-		     "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
-		     (module-name module)
-		     (module-name int2)
-		     name)
-	     (module-local-variable int2 name))))
+           (begin
+             (format (current-error-port)
+                     "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
+                     (module-name module)
+                     (module-name int2)
+                     name)
+             (module-local-variable int2 name))))
      
     (define (first module name int1 val1 int2 val2 var val)
       (or var (module-local-variable int1 name)))
@@ -3195,23 +3414,23 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (lookup-duplicates-handlers handler-names)
   (and handler-names
        (map (lambda (handler-name)
-	      (or (module-symbol-local-binding
-		   duplicate-handlers handler-name #f)
-		  (error "invalid duplicate handler name:"
-			 handler-name)))
-	    (if (list? handler-names)
-		handler-names
-		(list handler-names)))))
+              (or (module-symbol-local-binding
+                   duplicate-handlers handler-name #f)
+                  (error "invalid duplicate handler name:"
+                         handler-name)))
+            (if (list? handler-names)
+                handler-names
+                (list handler-names)))))
 
 (define default-duplicate-binding-procedures
   (make-mutable-parameter #f))
 
 (define default-duplicate-binding-handler
   (make-mutable-parameter '(replace warn-override-core warn last)
-			  (lambda (handler-names)
-			    (default-duplicate-binding-procedures
-			      (lookup-duplicates-handlers handler-names))
-			    handler-names)))
+                          (lambda (handler-names)
+                            (default-duplicate-binding-procedures
+                              (lookup-duplicates-handlers handler-names))
+                            handler-names)))
 
 
 
@@ -3250,6 +3469,7 @@ module '(ice-9 q) '(make-q q-length))}."
 (define %cond-expand-features
   ;; Adjust the above comment when changing this.
   '(guile
+    guile-2
     r5rs
     srfi-0   ;; cond-expand itself
     srfi-4   ;; homogenous numeric vectors
@@ -3270,9 +3490,9 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (cond-expand-provide module features)
   (let ((mod (module-public-interface module)))
     (and mod
-	 (hashq-set! %cond-expand-table mod
-		     (append (hashq-ref %cond-expand-table mod '())
-			     features)))))
+         (hashq-set! %cond-expand-table mod
+                     (append (hashq-ref %cond-expand-table mod '())
+                             features)))))
 
 (define-macro (cond-expand . clauses)
   (let ((syntax-error (lambda (cl)
@@ -3341,9 +3561,9 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (use-srfis srfis)
   (process-use-modules
    (map (lambda (num)
-	  (list (list 'srfi (string->symbol
-			     (string-append "srfi-" (number->string num))))))
-	srfis)))
+          (list (list 'srfi (string->symbol
+                             (string-append "srfi-" (number->string num))))))
+        srfis)))
 
 
 
@@ -3406,8 +3626,8 @@ module '(ice-9 q) '(make-q q-length))}."
 
     ;; Load emacs interface support if emacs option is given.
     (if (and (module-defined? guile-user-module 'use-emacs-interface)
-	     (module-ref guile-user-module 'use-emacs-interface))
-	(load-emacs-interface))
+             (module-ref guile-user-module 'use-emacs-interface))
+        (load-emacs-interface))
 
     ;; Use some convenient modules (in reverse order)
 
@@ -3415,72 +3635,71 @@ module '(ice-9 q) '(make-q q-length))}."
     (process-use-modules 
      (append
       '(((ice-9 r5rs))
-	((ice-9 session))
-	((ice-9 debug)))
+        ((ice-9 session))
+        ((ice-9 debug)))
       (if (provided? 'regex)
-	  '(((ice-9 regex)))
-	  '())
+          '(((ice-9 regex)))
+          '())
       (if (provided? 'threads)
-	  '(((ice-9 threads)))
-	  '())))
+          '(((ice-9 threads)))
+          '())))
     ;; load debugger on demand
-    (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
+    (module-autoload! guile-user-module '(system vm debug) '(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")
-			 (,SIGSEGV
-			  . "Bad memory access (Segmentation violation)"))
-		       '())))
+          (start-repl (@ (system repl repl) start-repl))
+          (signals (if (provided? 'posix)
+                       `((,SIGINT . "User interrupt")
+                         (,SIGFPE . "Arithmetic error")
+                         (,SIGSEGV
+                          . "Bad memory access (Segmentation violation)"))
+                       '())))
       ;; no SIGBUS on mingw
       (if (defined? 'SIGBUS)
-	  (set! signals (acons SIGBUS "Bad memory access (bus error)"
-			       signals)))
+          (set! signals (acons SIGBUS "Bad memory access (bus error)"
+                               signals)))
 
       (dynamic-wind
 
-	  ;; call at entry
-	  (lambda ()
-	    (let ((make-handler (lambda (msg)
-				  (lambda (sig)
-				    ;; Make a backup copy of the stack
-				    (fluid-set! before-signal-stack
-						(fluid-ref the-last-stack))
-				    (save-stack 2)
-				    (scm-error 'signal
-					       #f
-					       msg
-					       #f
-					       (list sig))))))
-	      (set! old-handlers
-		    (map (lambda (sig-msg)
-			   (sigaction (car sig-msg)
-				      (make-handler (cdr sig-msg))))
-			 signals))))
-
-	  ;; the protected thunk.
-	  (lambda ()
+          ;; call at entry
+          (lambda ()
+            (let ((make-handler (lambda (msg)
+                                  (lambda (sig)
+                                    ;; Make a backup copy of the stack
+                                    (fluid-set! before-signal-stack
+                                                (fluid-ref the-last-stack))
+                                    (save-stack 2)
+                                    (scm-error 'signal
+                                               #f
+                                               msg
+                                               #f
+                                               (list sig))))))
+              (set! old-handlers
+                    (map (lambda (sig-msg)
+                           (sigaction (car sig-msg)
+                                      (make-handler (cdr sig-msg))))
+                         signals))))
+
+          ;; the protected thunk.
+          (lambda ()
             (let ((status (start-repl 'scheme)))
-	      (run-hook exit-hook)
-	      status))
-
-	  ;; call at exit.
-	  (lambda ()
-	    (map (lambda (sig-msg old-handler)
-		   (if (not (car old-handler))
-		       ;; restore original C handler.
-		       (sigaction (car sig-msg) #f)
-		       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
-		       (sigaction (car sig-msg)
-				  (car old-handler)
-				  (cdr old-handler))))
-		 signals old-handlers))))))
+              (run-hook exit-hook)
+              status))
+
+          ;; call at exit.
+          (lambda ()
+            (map (lambda (sig-msg old-handler)
+                   (if (not (car old-handler))
+                       ;; restore original C handler.
+                       (sigaction (car sig-msg) #f)
+                       ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+                       (sigaction (car sig-msg)
+                                  (car old-handler)
+                                  (cdr old-handler))))
+                 signals old-handlers))))))
 
 ;;; This hook is run at the very end of an interactive session.
 ;;;
@@ -3492,26 +3711,21 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 
 (begin-deprecated
- (define (feature? sym)
-   (issue-deprecation-warning
-    "`feature?' is deprecated.  Use `provided?' instead.")
-   (provided? sym)))
-
-(begin-deprecated
- (primitive-load-path "ice-9/deprecated"))
+ (module-use! the-scm-module (resolve-interface '(ice-9 deprecated))))
 
 
 
 ;;; Place the user in the guile-user module.
 ;;;
 
-;;; FIXME: annotate ?
-;; (define (syncase exp)
-;;   (with-fluids ((expansion-eval-closure
-;; 		 (module-eval-closure (current-module))))
-;;     (deannotate/source-properties (sc-expand (annotate exp)))))
+;; FIXME:
+(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 
 (define-module (guile-user)
   #:autoload (system base compile) (compile))
 
+;; Remain in the `(guile)' module at compilation-time so that the
+;; `-Wunused-toplevel' warning works as expected.
+(eval-when (compile) (set-current-module the-root-module))
+
 ;;; boot-9.scm ends here