X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/37620f3f4e067be9a51b5740698e30c7b1de3a86..5a79300f8596c4dc3ff71e9faa587531f76798f7:/module/ice-9/boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 3928d1ec8..0f89dcece 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -334,12 +334,13 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; have booted.
 (define (module-name x)
   '(guile))
+(define (module-add! module sym var)
+  (hashq-set! (%get-pre-modules-obarray) sym var))
 (define (module-define! module sym val)
   (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
     (if v
         (variable-set! v val)
-        (hashq-set! (%get-pre-modules-obarray) sym
-                    (make-variable val)))))
+        (module-add! (current-module) sym (make-variable val)))))
 (define (module-ref module sym)
   (let ((v (module-variable module sym)))
     (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
@@ -472,6 +473,116 @@ If there is no handler at all, Guile prints an error and then exits."
        (with-syntax ((s (datum->syntax x (syntax-source x))))
          #''s)))))
 
+(define-syntax define-once
+  (syntax-rules ()
+    ((_ sym val)
+     (define sym
+       (if (module-locally-bound? (current-module) 'sym) sym val)))))
+
+
+
+;;;
+;;; Extensible exception printing.
+;;;
+
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
+
+(let ((exception-printers '()))
+  (define (print-location frame port)
+    (let ((source (and=> frame frame-source)))
+      ;; source := (addr . (filename . (line . column)))
+      (if source
+          (let ((filename (or (cadr source) "<unnamed port>"))
+                (line (caddr source))
+                (col (cdddr source)))
+            (format port "~a:~a:~a: " filename line col))
+          (format port "ERROR: "))))
+
+  (set! set-exception-printer!
+        (lambda (key proc)
+          (set! exception-printers (acons key proc exception-printers))))
+
+  (set! print-exception
+        (lambda (port frame key args)
+          (define (default-printer)
+            (format port "Throw to key `~a' with args `~s'." key args))
+
+          (if frame
+              (let ((proc (frame-procedure frame)))
+                (print-location frame port)
+                (format port "In procedure ~a:\n"
+                        (or (procedure-name proc) proc))))
+
+          (print-location frame port)
+          (catch #t
+            (lambda ()
+              (let ((printer (assq-ref exception-printers key)))
+                (if printer
+                    (printer port key args default-printer)
+                    (default-printer))))
+            (lambda (k . args)
+              (format port "Error while printing exception.")))
+          (newline port)
+          (force-output port))))
+
+;;;
+;;; Printers for those keys thrown by Guile.
+;;;
+(let ()
+  (define (scm-error-printer port key args default-printer)
+    ;; Abuse case-lambda as a pattern matcher, given that we don't have
+    ;; ice-9 match at this point.
+    (apply (case-lambda
+             ((subr msg args . rest)
+              (if subr
+                  (format port "In procedure ~a: " subr))
+              (apply format port msg args))
+             (_ (default-printer)))
+           args))
+
+  (define (syntax-error-printer port key args default-printer)
+    (apply (case-lambda
+             ((who what where form subform . extra)
+              (format port "Syntax error:\n")
+              (if where
+                  (let ((file (or (assq-ref where 'filename) "unknown file"))
+                        (line (and=> (assq-ref where 'line) 1+))
+                        (col (assq-ref where 'column)))
+                    (format port "~a:~a:~a: " file line col))
+                  (format port "unknown location: "))
+              (if who
+                  (format port "~a: " who))
+              (format port "~a" what)
+              (if subform
+                  (format port " in subform ~s of ~s" subform form)
+                  (if form
+                      (format port " in form ~s" form))))
+             (_ (default-printer)))
+           args))
+
+  (set-exception-printer! 'goops-error scm-error-printer)
+  (set-exception-printer! 'host-not-found scm-error-printer)
+  (set-exception-printer! 'keyword-argument-error scm-error-printer)
+  (set-exception-printer! 'misc-error scm-error-printer)
+  (set-exception-printer! 'no-data scm-error-printer)
+  (set-exception-printer! 'no-recovery scm-error-printer)
+  (set-exception-printer! 'null-pointer-error scm-error-printer)
+  (set-exception-printer! 'out-of-range scm-error-printer)
+  (set-exception-printer! 'program-error scm-error-printer)
+  (set-exception-printer! 'read-error scm-error-printer)
+  (set-exception-printer! 'regular-expression-syntax scm-error-printer)
+  (set-exception-printer! 'signal scm-error-printer)
+  (set-exception-printer! 'stack-overflow scm-error-printer)
+  (set-exception-printer! 'system-error scm-error-printer)
+  (set-exception-printer! 'try-again scm-error-printer)
+  (set-exception-printer! 'unbound-variable scm-error-printer)
+  (set-exception-printer! 'wrong-number-of-args scm-error-printer)
+  (set-exception-printer! 'wrong-type-arg scm-error-printer)
+
+  (set-exception-printer! 'syntax-error syntax-error-printer))
+
 
 
 
@@ -516,13 +627,14 @@ If there is no handler at all, Guile prints an error and then exits."
 
 ;;; {Deprecation}
 ;;;
-;;; Depends on: defmacro
-;;;
 
-(defmacro begin-deprecated forms
-  (if (include-deprecated-features)
-      `(begin ,@forms)
-      `(begin)))
+(define-syntax begin-deprecated
+  (lambda (x)
+    (syntax-case x ()
+      ((_ form form* ...)
+       (if (include-deprecated-features)
+           #'(begin form form* ...)
+           #'(begin))))))
 
 
 
@@ -530,6 +642,29 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define (identity x) x)
+
+(define (compose proc . rest)
+  "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+  (if (null? rest)
+      proc
+      (let ((g (apply compose rest)))
+        (lambda args
+          (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+  "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+  (lambda args
+    (not (apply proc args))))
+
+(define (const value)
+  "Return a procedure that accepts any number of arguments and returns
+VALUE."
+  (lambda _
+    value))
+
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 
@@ -557,10 +692,18 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; properties within the object itself.
 
 (define (make-object-property)
-  (let ((prop (primitive-make-property #f)))
+  (define-syntax with-mutex
+    (syntax-rules ()
+      ((_ lock exp)
+       (dynamic-wind (lambda () (lock-mutex lock))
+                     (lambda () exp)
+                     (lambda () (unlock-mutex lock))))))
+  (let ((prop (make-weak-key-hash-table))
+        (lock (make-mutex)))
     (make-procedure-with-setter
-     (lambda (obj) (primitive-property-ref prop obj))
-     (lambda (obj val) (primitive-property-set! prop obj val)))))
+     (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
+     (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+
 
 
 
@@ -1027,11 +1170,6 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; This is mostly for the internal use of the code generated by
 ;; scm_compile_shell_switches.
 
-(define (turn-on-debugging)
-  (debug-enable 'debug)
-  (debug-enable 'backtrace)
-  (read-enable 'positions))
-
 (define (load-user-init)
   (let* ((home (or (getenv "HOME")
                    (false-if-exception (passwd:dir (getpwuid (getuid))))
@@ -1055,7 +1193,7 @@ If there is no handler at all, Guile prints an error and then exits."
                                      (or (fluid-ref %stacks) '()))))
          (thunk)))
      (lambda (k . args)
-              (%start-stack tag (lambda () (apply k args)))))))
+       (%start-stack tag (lambda () (apply k args)))))))
 (define-syntax start-stack
   (syntax-rules ()
     ((_ tag exp)
@@ -1088,67 +1226,6 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (set! %load-hook %load-announce)
 
-(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)
-                  ;; This use of @ is (ironically?) boot-safe, as modules have
-                  ;; not been booted yet, so the resolve-module call in psyntax
-                  ;; doesn't try to load a module, and compile-file will be
-                  ;; treated as a function, not a macro.
-                  (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))))))
-
 
 
 ;;; {Reader Extensions}
@@ -1460,48 +1537,34 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; Create a new module, perhaps with a particular size of obarray,
 ;; initial uses list, or binding procedure.
 ;;
-(define make-module
-    (lambda args
-
-      (define (parse-arg 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))
+(define* (make-module #:optional (size 31) (uses '()) (binder #f))
+  (define %default-import-size
+    ;; Typical number of imported bindings actually used by a module.
+    600)
+
+  (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) #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))
 
-      (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 macroexpand
-                                          #f #f #f
-                                          (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))
-
-          module))))
+    module))
 
 
 
@@ -1816,36 +1879,32 @@ If there is no handler at all, Guile prints an error and then exits."
 (define (module-define-submodule! module name submodule)
   (hashq-set! (module-submodules module) name submodule))
 
-
-
-;;; {Low Level Bootstrapping}
-;;;
-
-;; make-root-module
-
-;; A root module uses the pre-modules-obarray as its obarray.  This
-;; special obarray accumulates all bindings that have been established
-;; before the module system is fully booted.
+;; It used to be, however, that module names were also present in the
+;; value namespace. When we enable deprecated code, we preserve this
+;; legacy behavior.
 ;;
-;; (The obarray continues to be used by code that has been closed over
-;;  before the module system has been booted.)
-
-(define (make-root-module)
-  (let ((m (make-module 0)))
-    (set-module-obarray! m (%get-pre-modules-obarray))
-    m))
-
-;; make-scm-module
-
-;; The root interface is a module that uses the same obarray as the
-;; root module.  It does not allow new definitions, tho.
-
-(define (make-scm-module)
-  (let ((m (make-module 0)))
-    (set-module-obarray! m (%get-pre-modules-obarray))
-    (set-module-eval-closure! m (standard-interface-eval-closure m))
-    m))
-
+;; These shims are defined here instead of in deprecated.scm because we
+;; need their definitions before loading other modules.
+;;
+(begin-deprecated
+ (define (module-ref-submodule module name)
+   (or (hashq-ref (module-submodules module) name)
+       (and (module-submodule-binder module)
+            ((module-submodule-binder module) module name))
+       (let ((var (module-local-variable module name)))
+         (and var (variable-bound? var) (module? (variable-ref var))
+              (begin
+                (warn "module" module "not in submodules table")
+                (variable-ref var))))))
+
+ (define (module-define-submodule! module name submodule)
+   (let ((var (module-local-variable module name)))
+     (if (and var
+              (or (not (variable-bound? var))
+                  (not (module? (variable-ref var)))))
+         (warn "defining module" module ": not overriding local definition" var)
+         (module-define! module name submodule)))
+   (hashq-set! (module-submodules module) name submodule)))
 
 
 
@@ -1865,22 +1924,6 @@ If there is no handler at all, Guile prints an error and then exits."
                     (set-current-module outer-module)
                     (set! outer-module #f)))))
 
-(define basic-load load)
-
-(define* (load-module filename #:optional reader)
-  (save-module-excursion
-   (lambda ()
-     (let ((oldname (and (current-load-port)
-                         (port-filename (current-load-port)))))
-       (basic-load (if (and oldname
-                            (> (string-length filename) 0)
-                            (not (char=? (string-ref filename 0) #\/))
-                            (not (string=? (dirname oldname) ".")))
-                       (string-append (dirname oldname) "/" filename)
-                       filename)
-                   reader)))))
-
-
 
 
 ;;; {MODULE-REF -- exported}
@@ -1959,10 +2002,16 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
 ;;
 (define (module-use-interfaces! module interfaces)
-  (set-module-uses! module
-                    (append (module-uses module) interfaces))
-  (hash-clear! (module-import-obarray module))
-  (module-modified module))
+  (let ((prev (filter (lambda (used)
+                        (and-map (lambda (iface)
+                                   (not (equal? (module-name used)
+                                                (module-name iface))))
+                                 interfaces))
+                      (module-uses module))))
+    (set-module-uses! module
+                      (append prev interfaces))
+    (hash-clear! (module-import-obarray module))
+    (module-modified module)))
 
 
 
@@ -2081,12 +2130,23 @@ If there is no handler at all, Guile prints an error and then exits."
               (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))
+(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))
 
 
 
@@ -2102,15 +2162,38 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define (set-system-module! m s)
   (set-procedure-property! (module-eval-closure m) 'system-module s))
-(define the-root-module (make-root-module))
-(define the-scm-module (make-scm-module))
-(set-module-public-interface! the-root-module the-scm-module)
-(set-module-name! the-root-module '(guile))
-(set-module-name! the-scm-module '(guile))
-(set-module-kind! the-scm-module 'interface)
-(set-system-module! the-root-module #t)
-(set-system-module! the-scm-module #t)
 
+;; The root module uses the pre-modules-obarray as its obarray.  This
+;; special obarray accumulates all bindings that have been established
+;; before the module system is fully booted.
+;;
+;; (The obarray continues to be used by code that has been closed over
+;;  before the module system has been booted.)
+;;
+(define the-root-module
+  (let ((m (make-module 0)))
+    (set-module-obarray! m (%get-pre-modules-obarray))
+    (set-module-name! m '(guile))
+    (set-system-module! m #t)
+    m))
+
+;; The root interface is a module that uses the same obarray as the
+;; root module.  It does not allow new definitions, tho.
+;;
+(define the-scm-module
+  (let ((m (make-module 0)))
+    (set-module-obarray! m (%get-pre-modules-obarray))
+    (set-module-eval-closure! m (standard-interface-eval-closure m))
+    (set-module-name! m '(guile))
+    (set-module-kind! m 'interface)
+    (set-system-module! m #t)
+
+    ;; In Guile 1.8 and earlier M was its own public interface.
+    (set-module-public-interface! m m)
+
+    m))
+
+(set-module-public-interface! the-root-module the-scm-module)
 
 
 
@@ -2125,7 +2208,7 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; 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 process-define-module #f)
+(define define-module* #f)
 (define process-use-modules #f)
 (define module-export! #f)
 (define default-duplicate-binding-procedures #f)
@@ -2240,6 +2323,19 @@ If there is no handler at all, Guile prints an error and then exits."
 (define (try-load-module name version)
   (try-module-autoload name version))
 
+(define (reload-module m)
+  "Revisit the source file corresponding to the module @var{m}."
+  (let ((f (module-filename m)))
+    (if f
+        (save-module-excursion
+         (lambda () 
+           ;; Re-set the initial environment, as in try-module-autoload.
+           (set-current-module (make-fresh-user-module))
+           (primitive-load-path f)
+           m))
+        ;; Though we could guess, we *should* know it.
+        (error "unknown file name for module" m))))
+
 (define (purify-module! module)
   "Removes bindings in MODULE which are inherited from the (guile) module."
   (let ((use-list (module-uses module)))
@@ -2336,135 +2432,78 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; This function is called from "modules.c".  If you change it, be
 ;; sure to update "modules.c" as well.
 
-(define (process-define-module args)
-  (let* ((module-id (car args))
-         (module (resolve-module module-id #f))
-         (kws (cdr args))
-         (unrecognized (lambda (arg)
-                         (error "unrecognized define-module argument" arg))))
+(define* (define-module* name
+           #:key filename pure version (duplicates '())
+           (imports '()) (exports '()) (replacements '())
+           (re-exports '()) (autoloads '()) transformer)
+  (define (list-of pred l)
+    (or (null? l)
+        (and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
+  (define (valid-export? x)
+    (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x)))))
+  (define (valid-autoload? x)
+    (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x))))
+  
+  (define (resolve-imports imports)
+    (define (resolve-import import-spec)
+      (if (list? import-spec)
+          (apply resolve-interface import-spec)
+          (error "unexpected use-module specification" import-spec)))
+    (let lp ((imports imports) (out '()))
+      (cond
+       ((null? imports) (reverse! out))
+       ((pair? imports)
+        (lp (cdr imports)
+            (cons (resolve-import (car imports)) out)))
+       (else (error "unexpected tail of imports list" imports)))))
+
+  ;; We could add a #:no-check arg, set by the define-module macro, if
+  ;; these checks are taking too much time.
+  ;;
+  (let ((module (resolve-module name #f)))
     (beautify-user-module! module)
-    (let loop ((kws kws)
-               (reversed-interfaces '())
-               (exports '())
-               (re-exports '())
-               (replacements '())
-               (autoloads '()))
-
-      (if (null? kws)
-          (call-with-deferred-observers
-           (lambda ()
-             (module-use-interfaces! module (reverse reversed-interfaces))
-             (module-export! module exports)
-             (module-replace! module replacements)
-             (module-re-export! module re-exports)
-             (if (not (null? autoloads))
-                 (apply module-autoload! module autoloads))))
-          (case (car kws)
-            ((#:use-module #:use-syntax)
-             (or (pair? (cdr kws))
-                 (unrecognized kws))
-             (cond
-              ((equal? (caadr kws) '(ice-9 syncase))
-               (issue-deprecation-warning
-                "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
-               (loop (cddr kws)
-                     reversed-interfaces
-                     exports
-                     re-exports
-                     replacements
-                     autoloads))
-              (else
-               (let* ((interface-args (cadr kws))
-                      (interface (apply resolve-interface interface-args)))
-                 (and (eq? (car kws) #:use-syntax)
-                      (or (symbol? (caar interface-args))
-                          (error "invalid module name for use-syntax"
-                                 (car interface-args)))
-                      (set-module-transformer!
-                       module
-                       (module-ref interface
-                                   (car (last-pair (car interface-args)))
-                                   #f)))
-                 (loop (cddr kws)
-                       (cons interface reversed-interfaces)
-                       exports
-                       re-exports
-                       replacements
-                       autoloads)))))
-            ((#:autoload)
-             (or (and (pair? (cdr kws)) (pair? (cddr kws)))
-                 (unrecognized kws))
-             (loop (cdddr kws)
-                   reversed-interfaces
-                   exports
-                   re-exports
-                   replacements
-                   (let ((name (cadr kws))
-                         (bindings (caddr kws)))
-                     (cons* name bindings autoloads))))
-            ((#:no-backtrace)
-             (set-system-module! module #t)
-             (loop (cdr kws) reversed-interfaces exports re-exports
-                   replacements autoloads))
-            ((#:pure)
-             (purify-module! module)
-             (loop (cdr kws) reversed-interfaces exports re-exports
-                   replacements autoloads))
-            ((#: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))
-             (set-module-duplicates-handlers!
-              module
-              (lookup-duplicates-handlers (cadr kws)))
-             (loop (cddr kws) reversed-interfaces exports re-exports
-                   replacements autoloads))
-            ((#:export #:export-syntax)
-             (or (pair? (cdr kws))
-                 (unrecognized kws))
-             (loop (cddr kws)
-                   reversed-interfaces
-                   (append (cadr kws) exports)
-                   re-exports
-                   replacements
-                   autoloads))
-            ((#:re-export #:re-export-syntax)
-             (or (pair? (cdr kws))
-                 (unrecognized kws))
-             (loop (cddr kws)
-                   reversed-interfaces
-                   exports
-                   (append (cadr kws) re-exports)
-                   replacements
-                   autoloads))
-            ((#:replace #:replace-syntax)
-             (or (pair? (cdr kws))
-                 (unrecognized kws))
-             (loop (cddr kws)
-                   reversed-interfaces
-                   exports
-                   re-exports
-                   (append (cadr kws) replacements)
-                   autoloads))
-            ((#: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)))))
+    (if filename
+        (set-module-filename! module filename))
+    (if pure
+        (purify-module! module))
+    (if version
+        (begin 
+          (if (not (list-of integer? version))
+              (error "expected list of integers for version"))
+          (set-module-version! module version)
+          (set-module-version! (module-public-interface module) version)))
+    (if (pair? duplicates)
+        (let ((handlers (lookup-duplicates-handlers duplicates)))
+          (set-module-duplicates-handlers! module handlers)))
+
+    (let ((imports (resolve-imports imports)))
+      (call-with-deferred-observers
+       (lambda ()
+         (if (pair? imports)
+             (module-use-interfaces! module imports))
+         (if (list-of valid-export? exports)
+             (if (pair? exports)
+                 (module-export! module exports))
+             (error "expected exports to be a list of symbols or symbol pairs"))
+         (if (list-of valid-export? replacements)
+             (if (pair? replacements)
+                 (module-replace! module replacements))
+             (error "expected replacements to be a list of symbols or symbol pairs"))
+         (if (list-of valid-export? re-exports)
+             (if (pair? re-exports)
+                 (module-re-export! module re-exports))
+             (error "expected re-exports to be a list of symbols or symbol pairs"))
+         ;; FIXME
+         (if (not (null? autoloads))
+             (apply module-autoload! module autoloads)))))
+
+    (if transformer
+        (if (and (pair? transformer) (list-of symbol? transformer))
+            (let ((iface (resolve-interface transformer))
+                  (sym (car (last-pair transformer))))
+              (set-module-transformer! module (module-ref iface sym)))
+            (error "expected transformer to be a module name" transformer)))
+    
     (run-hook module-defined-hook module)
     module))
 
@@ -2545,7 +2584,7 @@ module '(ice-9 q) '(make-q q-length))}."
                    ;; Here we could allow some other search strategy (other than
                    ;; primitive-load-path), for example using versions encoded
                    ;; into the file system -- but then we would have to figure
-                   ;; out how to locate the compiled file, do autocompilation,
+                   ;; out how to locate the compiled file, do auto-compilation,
                    ;; etc. Punt for now, and don't use versions when locating
                    ;; the file.
                    (primitive-load-path (in-vicinity dir-hint name) #f)
@@ -2625,23 +2664,14 @@ module '(ice-9 q) '(make-q q-length))}."
        (define-syntax option-set!
          (syntax-rules ()
            ((_ opt val)
-            (options (append (options) (list 'opt val))))))))))
-
-(define-option-interface
-  (eval-options-interface
-   (eval-options eval-enable eval-disable)
-   (eval-set!)))
+            (eval-when (eval load compile expand)
+              (options (append (options) (list 'opt val)))))))))))
 
 (define-option-interface
   (debug-options-interface
    (debug-options debug-enable debug-disable)
    (debug-set!)))
 
-(define-option-interface
-  (evaluator-traps-interface
-   (traps trap-enable trap-disable)
-   (trap-set!)))
-
 (define-option-interface
   (read-options-interface
    (read-options read-enable read-disable)
@@ -2672,20 +2702,21 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; {Running Repls}
 ;;;
 
+(define *repl-stack* (make-fluid))
+
 ;; Programs can call `batch-mode?' to see if they are running as part of a
 ;; script or if they are running interactively. REPL implementations ensure that
 ;; `batch-mode?' returns #f during their extent.
 ;;
-;; Programs can re-enter batch mode, for example after a fork, by calling
-;; `ensure-batch-mode!'. This will also restore signal handlers. It's not a
-;; great interface, though; it would be better to abort to the outermost prompt,
-;; and call a thunk there.
-(define *repl-level* (make-fluid))
 (define (batch-mode?)
-  (negative? (or (fluid-ref *repl-level*) -1)))
+  (null? (or (fluid-ref *repl-stack*) '())))
+
+;; Programs can re-enter batch mode, for example after a fork, by calling
+;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
+;; to abort to the outermost prompt, and call a thunk there.
+;;
 (define (ensure-batch-mode!)
-  (fluid-set! *repl-level* #f)
-  (restore-signals))
+  (set! batch-mode? (lambda () #t)))
 
 (define (quit . args)
   (apply throw 'quit args))
@@ -2708,6 +2739,10 @@ module '(ice-9 q) '(make-q q-length))}."
 (define before-print-hook (make-hook 1))
 (define after-print-hook (make-hook 1))
 
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
 ;;; The default repl-reader function.  We may override this if we've
 ;;; the readline library.
 (define repl-reader
@@ -2786,16 +2821,13 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; Return a list of expressions that evaluate to the appropriate
 ;; arguments for resolve-interface according to SPEC.
 
-(eval-when
- (compile)
- (if (memq 'prefix (read-options))
-     (error "boot-9 must be compiled with #:kw, not :kw")))
+(eval-when (compile)
+  (if (memq 'prefix (read-options))
+      (error "boot-9 must be compiled with #:kw, not :kw")))
 
 (define (keyword-like-symbol->keyword sym)
   (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
 
-;; 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)
@@ -2805,7 +2837,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
     
-    (define (quotify-iface args)
+    (define (parse-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
           (() (reverse! out))
@@ -2815,59 +2847,88 @@ module '(ice-9 q) '(make-q q-length))}."
           ((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)))
+           (loop #'in (cons* #',renamer #:renamer out)))
           ((kw val . in)
-           (loop #'in (cons* #''val #'kw out))))))
+           (loop #'in (cons* #'val #'kw out))))))
 
-    (define (quotify args)
+    (define (parse args imp exp rex rep aut)
       ;; 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 args ()
+        (()
+         (let ((imp (if (null? imp) '() #`(#:imports `#,imp)))
+               (exp (if (null? exp) '() #`(#:exports '#,exp)))
+               (rex (if (null? rex) '() #`(#:re-exports '#,rex)))
+               (rep (if (null? rep) '() #`(#:replacements '#,rep)))
+               (aut (if (null? aut) '() #`(#:autoloads '#,aut))))
+           #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
+        ;; The user wanted #:foo, but wrote :foo. Fix it.
+        ((sym . args) (keyword-like? #'sym)
+         (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
+                  imp exp rex rep aut))
+        ((kw . args) (not (keyword? (syntax->datum #'kw)))
+         (syntax-violation 'define-module "expected keyword arg" x #'kw))
+        ((#:no-backtrace . args)
+         ;; Ignore this one.
+         (parse #'args imp exp rex rep aut))
+        ((#:pure . args)
+         #`(#:pure #t . #,(parse #'args imp exp rex rep aut)))
+        ((kw)
+         (syntax-violation 'define-module "keyword arg without value" x #'kw))
+        ((#:version (v ...) . args)
+         #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#:duplicates (d ...) . args)
+         #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#:filename f . args)
+         #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
+        ((#:use-module (name name* ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+        ((#:use-syntax (name name* ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         #`(#:transformer '(name name* ...)
+            . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep aut)))
+        ((#:use-module ((name name* ...) arg ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args
+                (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+                exp rex rep aut))
+        ((#:export (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#:export-syntax (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#:re-export (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#:re-export-syntax (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#:replace (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#:replace-syntax (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#:autoload name bindings . args)
+         (parse #'args imp exp rex rep #`(#,@aut name bindings)))
+        ((kw val . args)
+         (syntax-violation 'define-module "unknown keyword or bad argument"
+                           #'kw #'val))))
     
     (syntax-case x ()
       ((_ (name name* ...) arg ...)
-       (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+       (and-map symbol? (syntax->datum #'(name name* ...)))
+       (with-syntax (((quoted-arg ...)
+                      (parse #'(arg ...) '() '() '() '() '()))
+                     ;; Ideally the filename is either a string or #f;
+                     ;; this hack is to work around a case in which
+                     ;; port-filename returns a symbol (`socket') for
+                     ;; sockets.
+                     (filename (let ((f (assq-ref (or (syntax-source x) '())
+                                                  'filename)))
+                                 (and (string? f) f))))
          #'(eval-when (eval load compile expand)
-             (let ((m (process-define-module
-                       (list '(name name* ...)
-                             #:filename (assq-ref
-                                         (or (current-source-location) '())
-                                         'filename)
-                             quoted-arg ...))))
+             (let ((m (define-module* '(name name* ...)
+                        #:filename filename quoted-arg ...)))
                (set-current-module m)
                m)))))))
 
@@ -3038,6 +3099,14 @@ module '(ice-9 q) '(make-q q-length))}."
         (lambda ()
           (module-re-export! (current-module) '(name ...))))))))
 
+(define-syntax export!
+  (syntax-rules ()
+    ((_ name ...)
+     (eval-when (eval load compile expand)
+       (call-with-deferred-observers
+        (lambda ()
+          (module-replace! (current-module) '(name ...))))))))
+
 (define-syntax export-syntax
   (syntax-rules ()
     ((_ name ...)
@@ -3048,23 +3117,18 @@ module '(ice-9 q) '(make-q q-length))}."
     ((_ name ...)
      (re-export name ...))))
 
-(define load load-module)
-
 
 
 ;;; {Parameters}
 ;;;
 
-(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 #:optional (converter identity))
-      (let ((fluid (make-fluid)))
-        (fluid-set! fluid (converter init))
-        (make fluid converter)))))
+(define* (make-mutable-parameter init #:optional (converter identity))
+  (let ((fluid (make-fluid)))
+    (fluid-set! fluid (converter init))
+    (case-lambda
+      (() (fluid-ref fluid))
+      ((val) (fluid-set! fluid (converter val))))))
+
 
 
 
@@ -3176,6 +3240,131 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
+;;; {`load'.}
+;;;
+;;; Load is tricky when combined with relative paths, compilation, and
+;;; the filesystem.  If a path is relative, what is it relative to?  The
+;;; path of the source file at the time it was compiled?  The path of
+;;; the compiled file?  What if both or either were installed?  And how
+;;; do you get that information?  Tricky, I say.
+;;;
+;;; To get around all of this, we're going to do something nasty, and
+;;; turn `load' into a macro.  That way it can know the path of the
+;;; source file with respect to which it was invoked, so it can resolve
+;;; relative paths with respect to the original source path.
+;;;
+;;; There is an exception, and that is that if the source file was in
+;;; the load path when it was compiled, instead of looking up against
+;;; the absolute source location, we load-from-path against the relative
+;;; source location.
+;;;
+
+(define %auto-compilation-options
+  ;; Default `compile-file' option when auto-compiling.
+  '(#:warnings (unbound-variable arity-mismatch)))
+
+(define* (load-in-vicinity dir path #: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 auto-compilation is enabled, will try auto-compilation, just
+  ;; as primitive-load-path does internally. primitive-load is
+  ;; unaffected. Returns #f if auto-compilation 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 name go-path)
+    (catch #t
+      (lambda ()
+        (let* ((scmstat (stat name))
+               (gostat  (stat go-path #f)))
+          (if (and gostat
+                   (or (> (stat:mtime gostat) (stat:mtime scmstat))
+                       (and (= (stat:mtime gostat) (stat:mtime scmstat))
+                            (>= (stat:mtimensec gostat)
+                                (stat:mtimensec 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-auto-compile
+                  (%warn-auto-compilation-enabled)
+                  (format (current-error-port) ";;; compiling ~a\n" name)
+                  (let ((cfn
+                         ((module-ref
+                               (resolve-interface '(system base compile))
+                               'compile-file)
+                              name
+                              #:opts %auto-compilation-options
+                              #: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)))
+
+  (define (absolute-path? path)
+    (string-prefix? "/" path))
+
+  (define (load-absolute abs-path)
+    (let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
+                 (and canon
+                      (let ((go-path (compiled-file-name canon)))
+                        (and go-path
+                             (fresh-compiled-file-name abs-path go-path)))))))
+      (if cfn
+          (load-compiled cfn)
+          (start-stack 'load-stack
+                       (primitive-load abs-path)))))
+  
+  (save-module-excursion
+   (lambda ()
+     (with-fluids ((current-reader reader)
+                   (%file-port-name-canonicalization 'relative))
+       (cond
+        ((or (absolute-path? path))
+         (load-absolute path))
+        ((absolute-path? dir)
+         (load-absolute (in-vicinity dir path)))
+        (else
+         (load-from-path (in-vicinity dir path))))))))
+
+(define-syntax load
+  (make-variable-transformer
+   (lambda (x)
+     (let* ((src (syntax-source x))
+            (file (and src (assq-ref src 'filename)))
+            (dir (and (string? file) (dirname file))))
+       (syntax-case x ()
+         ((_ arg ...)
+          #`(load-in-vicinity #,(or dir #'(getcwd)) arg ...))
+         (id
+          (identifier? #'id)
+          #`(lambda args
+              (apply load-in-vicinity #,(or dir #'(getcwd)) args))))))))
+
+
+
 ;;; {`cond-expand' for SRFI-0 support.}
 ;;;
 ;;; This syntactic form expands into different commands or
@@ -3236,66 +3425,45 @@ module '(ice-9 q) '(make-q q-length))}."
                      (append (hashq-ref %cond-expand-table mod '())
                              features)))))
 
-(define-macro (cond-expand . clauses)
-  (let ((syntax-error (lambda (cl)
-                        (error "invalid clause in `cond-expand'" cl))))
-    (letrec
-        ((test-clause
-          (lambda (clause)
-            (cond
-             ((symbol? clause)
-              (or (memq clause %cond-expand-features)
-                  (let lp ((uses (module-uses (current-module))))
-                    (if (pair? uses)
-                        (or (memq clause
-                                  (hashq-ref %cond-expand-table
-                                             (car uses) '()))
-                            (lp (cdr uses)))
-                        #f))))
-             ((pair? clause)
-              (cond
-               ((eq? 'and (car clause))
-                (let lp ((l (cdr clause)))
-                  (cond ((null? l)
-                         #t)
-                        ((pair? l)
-                         (and (test-clause (car l)) (lp (cdr l))))
-                        (else
-                         (syntax-error clause)))))
-               ((eq? 'or (car clause))
-                (let lp ((l (cdr clause)))
-                  (cond ((null? l)
-                         #f)
-                        ((pair? l)
-                         (or (test-clause (car l)) (lp (cdr l))))
-                        (else
-                         (syntax-error clause)))))
-               ((eq? 'not (car clause))
-                (cond ((not (pair? (cdr clause)))
-                       (syntax-error clause))
-                      ((pair? (cddr clause))
-                       ((syntax-error clause))))
-                (not (test-clause (cadr clause))))
-               (else
-                (syntax-error clause))))
-             (else
-              (syntax-error clause))))))
-      (let lp ((c clauses))
-        (cond
-         ((null? c)
-          (error "Unfulfilled `cond-expand'"))
-         ((not (pair? c))
-          (syntax-error c))
-         ((not (pair? (car c)))
-          (syntax-error (car c)))
-         ((test-clause (caar c))
-          `(begin ,@(cdar c)))
-         ((eq? (caar c) 'else)
-          (if (pair? (cdr c))
-              (syntax-error c))
-          `(begin ,@(cdar c)))
-         (else
-          (lp (cdr c))))))))
+(define-syntax cond-expand
+  (lambda (x)
+    (define (module-has-feature? mod sym)
+      (or-map (lambda (mod)
+                (memq sym (hashq-ref %cond-expand-table mod '())))
+              (module-uses mod)))
+
+    (define (condition-matches? condition)
+      (syntax-case condition (and or not)
+        ((and c ...)
+         (and-map condition-matches? #'(c ...)))
+        ((or c ...)
+         (or-map condition-matches? #'(c ...)))
+        ((not c)
+         (if (condition-matches? #'c) #f #t))
+        (c
+         (identifier? #'c)
+         (let ((sym (syntax->datum #'c)))
+           (if (memq sym %cond-expand-features)
+               #t
+               (module-has-feature? (current-module) sym))))))
+
+    (define (match clauses alternate)
+      (syntax-case clauses ()
+        (((condition form ...) . rest)
+         (if (condition-matches? #'condition)
+             #'(begin form ...)
+             (match #'rest alternate)))
+        (() (alternate))))
+
+    (syntax-case x (else)
+      ((_ clause ... (else form ...))
+       (match #'(clause ...)
+         (lambda ()
+           #'(begin form ...))))
+      ((_ clause ...)
+       (match #'(clause ...)
+         (lambda ()
+           (syntax-violation 'cond-expand "unfulfilled cond-expand" x)))))))
 
 ;; This procedure gets called from the startup code with a list of
 ;; numbers, which are the numbers of the SRFIs to be loaded on startup.
@@ -3312,48 +3480,22 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; srfi-55: require-extension
 ;;;
 
-(define-macro (require-extension extension-spec)
-  ;; This macro only handles the srfi extension, which, at present, is
-  ;; the only one defined by the standard.
-  (if (not (pair? extension-spec))
-      (scm-error 'wrong-type-arg "require-extension"
-                 "Not an extension: ~S" (list extension-spec) #f))
-  (let ((extension (car extension-spec))
-        (extension-args (cdr extension-spec)))
-    (case extension
-      ((srfi)
-       (let ((use-list '()))
-         (for-each
-          (lambda (i)
-            (if (not (integer? i))
-                (scm-error 'wrong-type-arg "require-extension"
-                           "Invalid srfi name: ~S" (list i) #f))
-            (let ((srfi-sym (string->symbol
-                             (string-append "srfi-" (number->string i)))))
-              (if (not (memq srfi-sym %cond-expand-features))
-                  (set! use-list (cons `(use-modules (srfi ,srfi-sym))
-                                       use-list)))))
-          extension-args)
-         (if (pair? use-list)
-             ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
-             `(begin ,@(reverse! use-list)))))
-      (else
-       (scm-error
-        'wrong-type-arg "require-extension"
-        "Not a recognized extension type: ~S" (list extension) #f)))))
-
-
-
-;;; {Load emacs interface support if emacs option is given.}
-;;;
-
-(define (named-module-use! user usee)
-  (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (load-emacs-interface)
-  (and (provided? 'debug-extensions)
-       (debug-enable 'backtrace))
-  (named-module-use! '(guile-user) '(ice-9 emacs)))
+(define-syntax require-extension
+  (lambda (x)
+    (syntax-case x (srfi)
+      ((_ (srfi n ...))
+       (and-map integer? (syntax->datum #'(n ...)))
+       (with-syntax
+           (((srfi-n ...)
+             (map (lambda (n)
+                    (datum->syntax x (symbol-append 'srfi- n)))
+                  (map string->symbol
+                       (map number->string (syntax->datum #'(n ...)))))))
+         #'(use-modules (srfi srfi-n) ...)))
+      ((_ (type arg ...))
+       (identifier? #'type)
+       (syntax-violation 'require-extension "Not a recognized extension type"
+                         x)))))
 
 
 
@@ -3363,91 +3505,6 @@ module '(ice-9 q) '(make-q q-length))}."
       (lambda () (fluid-ref using-readline?))
       (lambda (v) (fluid-set! using-readline? v)))))
 
-(define (top-repl)
-  (let ((guile-user-module (resolve-module '(guile-user))))
-
-    ;; 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))
-
-    ;; Use some convenient modules (in reverse order)
-
-    (set-current-module guile-user-module)
-    (process-use-modules 
-     (append
-      '(((ice-9 r5rs))
-        ((ice-9 session))
-        ((ice-9 debug)))
-      (if (provided? 'regex)
-          '(((ice-9 regex)))
-          '())
-      (if (provided? 'threads)
-          '(((ice-9 threads)))
-          '())))
-    ;; load debugger on demand
-    (module-autoload! guile-user-module '(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)
-          ;; We can't use @ here, as modules have been booted, but in Guile's
-          ;; build the srfi-1 helper lib hasn't been built yet, which will
-          ;; result in an error when (system repl repl) is loaded at compile
-          ;; time (to see if it is a macro or not).
-          (start-repl (module-ref (resolve-module '(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)))
-
-      (dynamic-wind
-
-          ;; call at entry
-          (lambda ()
-            (let ((make-handler (lambda (msg)
-                                  (lambda (sig)
-                                    (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))))))
-
-;;; This hook is run at the very end of an interactive session.
-;;;
-(define exit-hook (make-hook))
-
 
 
 ;;; {Deprecated stuff}
@@ -3464,8 +3521,10 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; FIXME:
 (module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 
+;; Set filename to #f to prevent reload.
 (define-module (guile-user)
-  #:autoload (system base compile) (compile))
+  #:autoload (system base compile) (compile compile-file)
+  #:filename #f)
 
 ;; Remain in the `(guile)' module at compilation-time so that the
 ;; `-Wunused-toplevel' warning works as expected.