Placate a number of `syntax-check' verifications.

[bpt/guile.git] / module / ice-9 / boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 987a4de..75097b5 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,7 +1,8 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
 ;;; -*- mode: scheme; coding: utf-8; -*-
 

-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;;;   2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+;;;;   Free Software Foundation, Inc.

 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public


@@ -69,23 +70,6 @@
 
 (define with-throw-handler #f)
 (let ()
 
 (define with-throw-handler #f)
 (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)
   (define (default-exception-handler k . args)
     (cond
      ((eq? k 'quit)


@@ -98,18 +82,21 @@
       (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
       (primitive-exit 1))))
 
       (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
       (primitive-exit 1))))
 

+  (define %running-exception-handlers (make-fluid '()))
+  (define %exception-handler (make-fluid default-exception-handler))
+

   (define (default-throw-handler prompt-tag catch-k)
   (define (default-throw-handler prompt-tag catch-k)

-    (let ((prev (exception-handler)))
+    (let ((prev (fluid-ref %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)
       (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)))
+    (let ((prev (fluid-ref %exception-handler)))

       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))

-            (let ((running (running-exception-handlers)))
+            (let ((running (fluid-ref %running-exception-handlers)))

               (with-fluids ((%running-exception-handlers (cons pre running)))
                 (if (not (memq pre running))
                     (apply pre thrown-k args))
               (with-fluids ((%running-exception-handlers (cons pre running)))
                 (if (not (memq pre running))
                     (apply pre thrown-k args))


@@ -192,9 +179,9 @@ for key @var{key}, then invoke @var{thunk}."
 
 If there is no handler at all, Guile prints an error and then exits."
           (if (not (symbol? key))
 
 If there is no handler at all, Guile prints an error and then exits."
           (if (not (symbol? key))

-              ((exception-handler) 'wrong-type-arg "throw"
+              ((fluid-ref %exception-handler) 'wrong-type-arg "throw"

                "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
                "Wrong type argument in position ~a: ~a" (list 1 key) (list key))

-              (apply (exception-handler) key args)))))
+              (apply (fluid-ref %exception-handler) key args)))))

 
 
 \f
 
 
 \f


@@ -227,9 +214,11 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
 
 (define pk peek)
 

+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)

 
 (define (warn . stuff)
 
 (define (warn . stuff)

-  (with-output-to-port (current-error-port)
+  (with-output-to-port (current-warning-port)

     (lambda ()
       (newline)
       (display ";;; WARNING ")
     (lambda ()
       (newline)
       (display ";;; WARNING ")


@@ -263,6 +252,50 @@ If there is no handler at all, Guile prints an error and then exits."
 
 \f
 
 
 \f
 

+;;; Boot versions of `map' and `for-each', enough to get the expander
+;;; running.
+;;;
+(define map
+  (case-lambda
+    ((f l)
+     (let map1 ((l l))
+       (if (null? l)
+           '()
+           (cons (f (car l)) (map1 (cdr l))))))
+    ((f l1 l2)
+     (let map2 ((l1 l1) (l2 l2))
+       (if (null? l1)
+           '()
+           (cons (f (car l1) (car l2))
+                 (map2 (cdr l1) (cdr l2))))))
+    ((f l1 . rest)
+     (let lp ((l1 l1) (rest rest))
+       (if (null? l1)
+           '()
+           (cons (apply f (car l1) (map car rest))
+                 (lp (cdr l1) (map cdr rest))))))))
+
+(define for-each
+  (case-lambda
+    ((f l)
+     (let for-each1 ((l l))
+       (if (pair? l)
+           (begin
+             (f (car l))
+             (for-each1 (cdr l))))))
+    ((f l1 l2)
+     (let for-each2 ((l1 l1) (l2 l2))
+       (if (pair? l1)
+           (begin
+             (f (car l1) (car l2))
+             (for-each2 (cdr l1) (cdr l2))))))
+    ((f l1 . rest)
+     (let lp ((l1 l1) (rest rest))
+       (if (pair? l1)
+           (begin
+             (apply f (car l1) (map car rest))
+             (lp (cdr l1) (map cdr rest))))))))
+

 ;;; {and-map and or-map}
 ;;;
 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
 ;;; {and-map and or-map}
 ;;;
 ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)


@@ -334,12 +367,13 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; have booted.
 (define (module-name x)
   '(guile))
 ;; 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)
 (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)))))
 (define (module-ref module sym)
   (let ((v (module-variable module sym)))
     (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))


@@ -459,9 +493,8 @@ If there is no handler at all, Guile prints an error and then exits."
     ((do "step" x y)
      y)))
 
     ((do "step" x y)
      y)))
 

-(define-syntax delay
-  (syntax-rules ()
-    ((_ exp) (make-promise (lambda () exp)))))
+(define-syntax-rule (delay exp)
+  (make-promise (lambda () exp)))

 
 (include-from-path "ice-9/quasisyntax")
 
 
 (include-from-path "ice-9/quasisyntax")
 


@@ -472,6 +505,260 @@ If there is no handler at all, Guile prints an error and then exits."
        (with-syntax ((s (datum->syntax x (syntax-source x))))
          #''s)))))
 
        (with-syntax ((s (datum->syntax x (syntax-source x))))
          #''s)))))
 

+(define-syntax-rule (define-once sym val)
+  (define sym
+    (if (module-locally-bound? (current-module) 'sym) sym val)))
+
+;;; The real versions of `map' and `for-each', with cycle detection, and
+;;; that use reverse! instead of recursion in the case of `map'.
+;;;
+(define map
+  (case-lambda
+    ((f l)
+     (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+       (if (pair? hare)
+           (if move?
+               (if (eq? tortoise hare)
+                   (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                              (list l) #f)
+                   (map1 (cdr hare) (cdr tortoise) #f
+                       (cons (f (car hare)) out)))
+               (map1 (cdr hare) tortoise #t
+                     (cons (f (car hare)) out)))
+           (if (null? hare)
+               (reverse! out)
+               (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                          (list l) #f)))))
+    
+    ((f l1 l2)
+     (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
+       (cond
+        ((pair? h1)
+         (cond
+          ((not (pair? h2))
+           (scm-error 'wrong-type-arg "map"
+                      (if (list? h2)
+                          "List of wrong length: ~S"
+                          "Not a list: ~S")
+                      (list l2) #f))
+          ((not move?)
+           (map2 (cdr h1) (cdr h2) t1 t2 #t
+                 (cons (f (car h1) (car h2)) out)))
+          ((eq? t1 h1)
+           (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                      (list l1) #f))
+          ((eq? t2 h2)
+           (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+                      (list l2) #f))
+          (else
+           (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
+                 (cons (f (car h1) (car h2)) out)))))
+
+        ((and (null? h1) (null? h2))
+         (reverse! out))
+        
+        ((null? h1)
+         (scm-error 'wrong-type-arg "map"
+                    (if (list? h2)
+                        "List of wrong length: ~S"
+                        "Not a list: ~S")
+                    (list l2) #f))
+        (else
+         (scm-error 'wrong-type-arg "map"
+                    "Not a list: ~S"
+                    (list l1) #f)))))
+
+    ((f l1 . rest)
+     (let ((len (length l1)))
+       (let mapn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (mapn (cdr rest))
+                 (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+     (let mapn ((l1 l1) (rest rest) (out '()))
+       (if (null? l1)
+           (reverse! out)
+           (mapn (cdr l1) (map cdr rest)
+                 (cons (apply f (car l1) (map car rest)) out)))))))
+
+(define map-in-order map)
+
+(define for-each
+  (case-lambda
+    ((f l)
+     (let for-each1 ((hare l) (tortoise l) (move? #f))
+       (if (pair? hare)
+           (if move?
+               (if (eq? tortoise hare)
+                   (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                              (list l) #f)
+                   (begin
+                     (f (car hare))
+                     (for-each1 (cdr hare) (cdr tortoise) #f)))
+               (begin
+                 (f (car hare))
+                 (for-each1 (cdr hare) tortoise #t)))
+           
+           (if (not (null? hare))
+               (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+                          (list l) #f)))))
+    
+    ((f l1 l2)
+     (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
+       (cond
+        ((and (pair? h1) (pair? h2))
+         (cond
+          ((not move?)
+           (f (car h1) (car h2))
+           (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
+          ((eq? t1 h1)
+           (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                      (list l1) #f))
+          ((eq? t2 h2)
+           (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+                      (list l2) #f))
+          (else
+           (f (car h1) (car h2))
+           (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
+
+        ((if (null? h1)
+             (or (null? h2) (pair? h2))
+             (and (pair? h1) (null? h2)))
+         (if #f #f))
+        
+        ((list? h1)
+         (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+                    (list h2) #f))
+        (else
+         (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
+                    (list h1) #f)))))
+
+    ((f l1 . rest)
+     (let ((len (length l1)))
+       (let for-eachn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (for-eachn (cdr rest))
+                 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+     
+     (let for-eachn ((l1 l1) (rest rest))
+       (if (pair? l1)
+           (begin
+             (apply f (car l1) (map car rest))
+             (for-eachn (cdr l1) (map cdr rest))))))))
+
+
+\f
+
+;;;
+;;; 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 (1+ 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 (or 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))
+
+  (define (getaddrinfo-error-printer port key args default-printer)
+    (format port "In procedure getaddrinfo: ~a" (gai-strerror (car 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)
+
+  (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
+

 
 \f
 
 
 \f
 


@@ -531,15 +818,36 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define (identity x) x)
 ;;;
 
 (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)
 
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 

-(define-syntax false-if-exception
-  (syntax-rules ()
-    ((_ expr)
-     (catch #t
-       (lambda () expr)
-       (lambda (k . args) #f)))))
+(define-syntax-rule (false-if-exception expr)
+  (catch #t
+    (lambda () expr)
+    (lambda (k . args) #f)))

 
 \f
 
 
 \f
 


@@ -558,10 +866,16 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; properties within the object itself.
 
 (define (make-object-property)
 ;; properties within the object itself.
 
 (define (make-object-property)

-  (let ((prop (primitive-make-property #f)))
+  (define-syntax-rule (with-mutex 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
     (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))))))
+

 
 \f
 
 
 \f
 


@@ -815,8 +1129,9 @@ If there is no handler at all, Guile prints an error and then exits."
 
 \f
 
 
 \f
 

-(if (provided? 'posix)
-    (primitive-load-path "ice-9/posix"))
+;; Load `posix.scm' even when not (provided? 'posix) so that we get the
+;; `stat' accessors.
+(primitive-load-path "ice-9/posix")

 
 (if (provided? 'socket)
     (primitive-load-path "ice-9/networking"))
 
 (if (provided? 'socket)
     (primitive-load-path "ice-9/networking"))


@@ -1028,11 +1343,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.
 
 ;; 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))))
 (define (load-user-init)
   (let* ((home (or (getenv "HOME")
                    (false-if-exception (passwd:dir (getpwuid (getuid))))


@@ -1056,11 +1366,10 @@ If there is no handler at all, Guile prints an error and then exits."
                                      (or (fluid-ref %stacks) '()))))
          (thunk)))
      (lambda (k . args)
                                      (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)))))
+       (%start-stack tag (lambda () (apply k args)))))))
+
+(define-syntax-rule (start-stack tag exp)
+  (%start-stack tag (lambda () exp)))

 
 \f
 
 
 \f
 


@@ -1079,7 +1388,7 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define (%load-announce file)
   (if %load-verbosely
 
 (define (%load-announce file)
   (if %load-verbosely

-      (with-output-to-port (current-error-port)
+      (with-output-to-port (current-warning-port)

         (lambda ()
           (display ";;; ")
           (display "loading ")
         (lambda ()
           (display ";;; ")
           (display "loading ")


@@ -1089,67 +1398,6 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (set! %load-hook %load-announce)
 
 
 (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))))))
-

 \f
 
 ;;; {Reader Extensions}
 \f
 
 ;;; {Reader Extensions}


@@ -1157,8 +1405,7 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;; Reader code for various "#c" forms.
 ;;;
 
 ;;; Reader code for various "#c" forms.
 ;;;
 

-(define read-eval? (make-fluid))
-(fluid-set! read-eval? #f)
+(define read-eval? (make-fluid #f))

 (read-hash-extend #\.
                   (lambda (c port)
                     (if (fluid-ref read-eval?)
 (read-hash-extend #\.
                   (lambda (c port)
                     (if (fluid-ref read-eval?)


@@ -1461,48 +1708,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.
 ;;
 ;; 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))
-
-      (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))
+(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))

 
 

-          module))))
+    module))

 
 
 \f
 
 
 \f


@@ -1817,36 +2050,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))
 
 (define (module-define-submodule! module name submodule)
   (hashq-set! (module-submodules module) name submodule))
 

-\f
-
-;;; {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)))

 
 \f
 
 
 \f
 


@@ -1866,22 +2095,6 @@ If there is no handler at all, Guile prints an error and then exits."
                     (set-current-module outer-module)
                     (set! outer-module #f)))))
 
                     (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)))))
-
-

 \f
 
 ;;; {MODULE-REF -- exported}
 \f
 
 ;;; {MODULE-REF -- exported}


@@ -1945,25 +2158,29 @@ If there is no handler at all, Guile prints an error and then exits."
         ;; Newly used modules must be appended rather than consed, so that
         ;; `module-variable' traverses the use list starting from the first
         ;; used module.
         ;; Newly used modules must be appended rather than consed, so that
         ;; `module-variable' traverses the use list starting from the first
         ;; used module.

-        (set-module-uses! module
-                          (append (filter (lambda (m)
-                                            (not
-                                             (equal? (module-name m)
-                                                     (module-name interface))))
-                                          (module-uses module))
-                                  (list interface)))
+        (set-module-uses! module (append (module-uses module)
+                                         (list interface)))

         (hash-clear! (module-import-obarray module))
         (module-modified module))))
 
 ;; MODULE-USE-INTERFACES! module interfaces
 ;;
         (hash-clear! (module-import-obarray module))
         (module-modified module))))
 
 ;; MODULE-USE-INTERFACES! module interfaces
 ;;

-;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
+;; Same as MODULE-USE!, but only notifies module observers after all
+;; interfaces are added to the inports list.

 ;;
 (define (module-use-interfaces! module interfaces)
 ;;
 (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* ((cur (module-uses module))
+         (new (let lp ((in interfaces) (out '()))
+                (if (null? in)
+                    (reverse out)
+                    (lp (cdr in)
+                        (let ((iface (car in)))
+                          (if (or (memq iface cur) (memq iface out))
+                              out
+                              (cons iface out))))))))
+    (set-module-uses! module (append cur new))
+    (hash-clear! (module-import-obarray module))
+    (module-modified module)))

 
 \f
 
 
 \f
 


@@ -2082,12 +2299,23 @@ If there is no handler at all, Guile prints an error and then exits."
               (loop cur (car tail) (cdr tail)))))))
 
 
               (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))

 
 
 
 
 
 


@@ -2103,15 +2331,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 (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)

 
 \f
 
 
 \f
 


@@ -2126,7 +2377,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.
 ;;
 ;; 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)
 (define process-use-modules #f)
 (define module-export! #f)
 (define default-duplicate-binding-procedures #f)


@@ -2241,6 +2492,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 (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)))
 (define (purify-module! module)
   "Removes bindings in MODULE which are inherited from the (guile) module."
   (let ((use-list (module-uses module)))


@@ -2337,135 +2601,79 @@ 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.
 
 ;; 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)
     (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)))
+    (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))
+         ;; Wait until modules have been loaded to resolve duplicates
+         ;; handlers.
+         (if (pair? duplicates)
+             (let ((handlers (lookup-duplicates-handlers duplicates)))
+               (set-module-duplicates-handlers! module handlers))))))
+
+    (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))
 
     (run-hook module-defined-hook module)
     module))
 


@@ -2546,7 +2754,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
                    ;; 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)
                    ;; etc. Punt for now, and don't use versions when locating
                    ;; the file.
                    (primitive-load-path (in-vicinity dir-hint name) #f)


@@ -2623,26 +2831,15 @@ module '(ice-9 q) '(make-q q-length))}."
                      flags)
            (interface options)
            (interface)))
                      flags)
            (interface options)
            (interface)))

-       (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!)))
+       (define-syntax-rule (option-set! opt val)
+         (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
   (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)
 (define-option-interface
   (read-options-interface
    (read-options read-enable read-disable)


@@ -2670,21 +2867,116 @@ module '(ice-9 q) '(make-q q-length))}."
 
 \f
 
 
 \f
 

+;;; {Parameters}
+;;;
+
+(define <parameter>
+  ;; Three fields: the procedure itself, the fluid, and the converter.
+  (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+  (let ((fluid (make-fluid (conv init))))
+    (make-struct <parameter> 0
+                 (case-lambda
+                   (() (fluid-ref fluid))
+                   ((x) (let ((prev (fluid-ref fluid)))
+                          (fluid-set! fluid (conv x))
+                          prev)))
+                 fluid conv)))
+
+(define (parameter? x)
+  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+  (if (parameter? p)
+      (struct-ref p 1)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+  (if (parameter? p)
+      (struct-ref p 2)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((param value) ...) body body* ...)
+       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+         #'(let ((p param) ...)
+             (if (not (parameter? p))
+                        (scm-error 'wrong-type-arg "parameterize"
+                                   "Not a parameter: ~S" (list p) #f))
+             ...
+             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+                           ...)
+               body body* ...)))))))
+
+\f
+;;;
+;;; Current ports as parameters.
+;;;
+
+(let ((fluid->parameter
+       (lambda (fluid conv)
+         (make-struct <parameter> 0
+                      (case-lambda
+                        (() (fluid-ref fluid))
+                        ((x) (let ((prev (fluid-ref fluid)))
+                               (fluid-set! fluid (conv x))
+                               prev)))
+                      fluid conv))))
+  (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+    (begin
+      (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+                                      (lambda (x)
+                                        (if (predicate x) x
+                                            (error msg x)))))
+      (module-remove! (current-module) 'fluid)))
+  
+  (port-parameterize! current-input-port %current-input-port-fluid
+                      input-port? "expected an input port")
+  (port-parameterize! current-output-port %current-output-port-fluid
+                      output-port? "expected an output port")
+  (port-parameterize! current-error-port %current-error-port-fluid
+                      output-port? "expected an output port"))
+
+
+\f
+;;;
+;;; Warnings.
+;;;
+
+(define current-warning-port
+  (make-parameter (current-error-port)
+                  (lambda (x)
+                    (if (output-port? x)
+                        x
+                        (error "expected an output port" x)))))
+
+
+\f
+

 ;;; {Running Repls}
 ;;;
 
 ;;; {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 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.
 ;;

+(define (batch-mode?)
+  (null? (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.
 ;; 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 *repl-level* (make-fluid))
-(define (batch-mode?)
-  (negative? (or (fluid-ref *repl-level*) -1)))
+;;

 (define (ensure-batch-mode!)
 (define (ensure-batch-mode!)

-  (fluid-set! *repl-level* #f))
+  (set! batch-mode? (lambda () #t)))

 
 (define (quit . args)
   (apply throw 'quit args))
 
 (define (quit . args)
   (apply throw 'quit args))


@@ -2707,12 +2999,35 @@ module '(ice-9 q) '(make-q q-length))}."
 (define before-print-hook (make-hook 1))
 (define after-print-hook (make-hook 1))
 
 (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
   (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
     (if (not (char-ready?))
 ;;; The default repl-reader function.  We may override this if we've
 ;;; the readline library.
 (define repl-reader
   (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
     (if (not (char-ready?))

-        (display (if (string? prompt) prompt (prompt))))
+        (begin
+          (display (if (string? prompt) prompt (prompt)))
+          ;; An interesting situation.  The printer resets the column to
+          ;; 0 by printing a newline, but we then advance it by printing
+          ;; the prompt.  However the port-column of the output port
+          ;; does not typically correspond with the actual column on the
+          ;; screen, because the input is echoed back!  Since the
+          ;; input is line-buffered and thus ends with a newline, the
+          ;; output will really start on column zero.  So, here we zero
+          ;; it out.  See bug 9664.
+          ;;
+          ;; Note that for similar reasons, the output-line will not
+          ;; reflect the actual line on the screen.  But given the
+          ;; possibility of multiline input, the fix is not as
+          ;; straightforward, so we don't bother.
+          ;;
+          ;; Also note that the readline implementation papers over
+          ;; these concerns, because it's readline itself printing the
+          ;; prompt, and not Guile.
+          (set-port-column! (current-output-port) 0)))

     (force-output)
     (run-hook before-read-hook)
     ((or reader read) (current-input-port))))
     (force-output)
     (run-hook before-read-hook)
     ((or reader read) (current-input-port))))


@@ -2750,13 +3065,11 @@ module '(ice-9 q) '(make-q q-length))}."
               (define-syntax #,(datum->syntax #'while 'break)
                 (lambda (x)
                   (syntax-case x ()
               (define-syntax #,(datum->syntax #'while 'break)
                 (lambda (x)
                   (syntax-case x ()

-                    ((_)
-                     #'(abort-to-prompt break-tag))
-                    ((_ . args)
-                     (syntax-violation 'break "too many arguments" x))
+                    ((_ arg (... ...))
+                     #'(abort-to-prompt break-tag arg (... ...)))

                     (_
                     (_

-                     #'(lambda ()
-                         (abort-to-prompt break-tag))))))
+                     #'(lambda args
+                         (apply abort-to-prompt break-tag args))))))

               (let lp ()
                 (call-with-prompt
                  continue-tag
               (let lp ()
                 (call-with-prompt
                  continue-tag


@@ -2769,12 +3082,14 @@ module '(ice-9 q) '(make-q q-length))}."
                          ((_ . args)
                           (syntax-violation 'continue "too many arguments" x))
                          (_
                          ((_ . args)
                           (syntax-violation 'continue "too many arguments" x))
                          (_

-                          #'(lambda args 
-                              (apply abort-to-prompt continue-tag args))))))
-                   (do () ((not cond)) body ...))
+                          #'(lambda ()
+                              (abort-to-prompt continue-tag))))))
+                   (do () ((not cond) #f) body ...))

                  (lambda (k) (lp)))))
                  (lambda (k) (lp)))))

-            (lambda (k)
-              #t)))))))
+            (lambda (k . args)
+              (if (null? args)
+                  #t
+                  (apply values args)))))))))

 
 
 \f
 
 
 \f


@@ -2785,16 +3100,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.
 
 ;; 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))))
 
 
 (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)
 (define-syntax define-module
   (lambda (x)
     (define (keyword-like? stx)


@@ -2804,7 +3116,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
     
     (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))
       (let loop ((in args) (out '()))
         (syntax-case in ()
           (() (reverse! out))


@@ -2814,59 +3126,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)
           ((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)
           ((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).
       ;; 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 #`(#,@imp ((name name* ...))) exp rex rep aut))
+        ((#:use-syntax (name name* ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         #`(#:transformer '(name name* ...)
+            . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
+        ((#:use-module ((name name* ...) arg ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args
+                #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
+                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 ...)
     
     (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)
          #'(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)))))))
 
                (set-current-module m)
                m)))))))
 


@@ -2928,21 +3269,17 @@ module '(ice-9 q) '(make-q q-length))}."
              (process-use-modules (list quoted-args ...))
              *unspecified*))))))
 
              (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 ...)))))
+(define-syntax-rule (use-syntax 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")
 
 
 (include-from-path "ice-9/r6rs-libraries")
 

-(define-syntax define-private
-  (syntax-rules ()
-    ((_ foo bar)
-     (define foo bar))))
+(define-syntax-rule (define-private foo bar)
+  (define foo bar))

 
 (define-syntax define-public
   (syntax-rules ()
 
 (define-syntax define-public
   (syntax-rules ()


@@ -2953,18 +3290,14 @@ module '(ice-9 q) '(make-q q-length))}."
        (define name val)
        (export name)))))
 
        (define name val)
        (export name)))))
 

-(define-syntax defmacro-public
-  (syntax-rules ()
-    ((_ name args . body)
-     (begin
-       (defmacro name args . body)
-       (export-syntax name)))))
+(define-syntax-rule (defmacro-public name args body ...)
+  (begin
+    (defmacro name args body ...)
+    (export-syntax name)))

 
 ;; And now for the most important macro.
 
 ;; And now for the most important macro.

-(define-syntax λ
-  (syntax-rules ()
-    ((_ formals body ...)
-     (lambda formals body ...))))
+(define-syntax-rule (λ formals body ...)
+  (lambda formals body ...))

 
 \f
 ;; Export a local variable
 
 \f
 ;; Export a local variable


@@ -2987,6 +3320,8 @@ module '(ice-9 q) '(make-q q-length))}."
                 (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)))
                 (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)))

+                  ;; FIXME: use a bit on variables instead of object
+                  ;; properties.

                   (set-object-property! var 'replace #t)
                   (module-add! public-i external-name var)))
               names)))
                   (set-object-property! var 'replace #t)
                   (module-add! public-i external-name var)))
               names)))


@@ -3021,57 +3356,41 @@ module '(ice-9 q) '(make-q q-length))}."
                          (module-add! public-i external-name var)))))
               names)))
 
                          (module-add! public-i external-name var)))))
               names)))
 

-(define-syntax export
-  (syntax-rules ()
-    ((_ name ...)
-     (eval-when (eval load compile expand)
-       (call-with-deferred-observers
-        (lambda ()
-          (module-export! (current-module) '(name ...))))))))
-
-(define-syntax re-export
-  (syntax-rules ()
-    ((_ name ...)
-     (eval-when (eval load compile expand)
-       (call-with-deferred-observers
-        (lambda ()
-          (module-re-export! (current-module) '(name ...))))))))
+(define-syntax-rule (export name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-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-rule (re-export name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-re-export! (current-module) '(name ...))))))

 
 

-(define-syntax export-syntax
-  (syntax-rules ()
-    ((_ name ...)
-     (export name ...))))
+(define-syntax-rule (export! name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-replace! (current-module) '(name ...))))))

 
 

-(define-syntax re-export-syntax
-  (syntax-rules ()
-    ((_ name ...)
-     (re-export name ...))))
+(define-syntax-rule (export-syntax name ...)
+  (export name ...))

 
 

-(define load load-module)
+(define-syntax-rule (re-export-syntax name ...)
+  (re-export name ...))

 
 \f
 
 ;;; {Parameters}
 ;;;
 
 
 \f
 
 ;;; {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 (converter init))))
+    (case-lambda
+      (() (fluid-ref fluid))
+      ((val) (fluid-set! fluid (converter val))))))
+

 
 \f
 
 
 \f
 


@@ -3110,7 +3429,7 @@ module '(ice-9 q) '(make-q q-length))}."
                  #f))
     
     (define (warn module name int1 val1 int2 val2 var val)
                  #f))
     
     (define (warn module name int1 val1 int2 val2 var val)

-      (format (current-error-port)
+      (format (current-warning-port)

               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
               (module-name module)
               name
               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
               (module-name module)
               name


@@ -3132,7 +3451,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin

-             (format (current-error-port)
+             (format (current-warning-port)

                      "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
                      (module-name module)
                      (module-name int2)
                      "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
                      (module-name module)
                      (module-name int2)


@@ -3183,6 +3502,151 @@ module '(ice-9 q) '(make-q q-length))}."
 
 \f
 
 
 \f
 

+;;; {`load'.}
+;;;
+;;; Load is tricky when combined with relative paths, compilation, and
+;;; the file system.  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 format)))
+
+(define* (load-in-vicinity dir path #:optional reader)
+  (define (canonical->suffix canon)
+    (cond
+     ((string-prefix? "/" canon) canon)
+     ((and (> (string-length canon) 2)
+           (eqv? (string-ref canon 1) #\:))
+      ;; Paths like C:... transform to /C...
+      (string-append "/" (substring canon 0 1) (substring canon 2)))
+     (else canon)))
+
+  ;; 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)
+    ;; FIXME: would probably be better just to append SHA1(canon-path)
+    ;; to the %compile-fallback-path, to avoid deep directory stats.
+    (and %compile-fallback-path
+         (string-append
+          %compile-fallback-path
+          (canonical->suffix 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  (and (not %fresh-auto-compile)
+                             (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-warning-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-warning-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-warning-port) ";;; compiled ~a\n" cfn)
+                    cfn))
+                 (else #f))))))
+      (lambda (k . args)
+        (format (current-warning-port)
+                ";;; WARNING: compilation of ~a failed:\n" name)
+        (for-each (lambda (s)
+                    (if (not (string-null? s))
+                        (format (current-warning-port) ";;; ~a\n" s)))
+                  (string-split
+                   (call-with-output-string
+                    (lambda (port) (print-exception port #f k args)))
+                   #\newline))
+        #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
+          (begin
+            (if %load-hook
+                (%load-hook abs-path))
+            (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))))))))
+
+\f
+

 ;;; {`cond-expand' for SRFI-0 support.}
 ;;;
 ;;; This syntactic form expands into different commands or
 ;;; {`cond-expand' for SRFI-0 support.}
 ;;;
 ;;; This syntactic form expands into different commands or


@@ -3225,6 +3689,8 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-6   ;; open-input-string etc, in the guile core
     srfi-13  ;; string library
     srfi-14  ;; character sets
     srfi-6   ;; open-input-string etc, in the guile core
     srfi-13  ;; string library
     srfi-14  ;; character sets

+    srfi-23  ;; `error` procedure
+    srfi-39  ;; parameterize

     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
     ))
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
     ))


@@ -3243,66 +3709,45 @@ module '(ice-9 q) '(make-q q-length))}."
                      (append (hashq-ref %cond-expand-table mod '())
                              features)))))
 
                      (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.
 
 ;; 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.


@@ -3319,48 +3764,60 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; srfi-55: require-extension
 ;;;
 
 ;;; 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)))))
+(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)))))

 
 \f
 
 \f

-
-;;; {Load emacs interface support if emacs option is given.}
+;;; Defining transparently inlinable procedures

 ;;;
 
 ;;;
 

-(define (named-module-use! user usee)
-  (module-use! (resolve-module user) (resolve-interface usee)))
+(define-syntax define-inlinable
+  ;; Define a macro and a procedure such that direct calls are inlined, via
+  ;; the macro expansion, whereas references in non-call contexts refer to
+  ;; the procedure.  Inspired by the `define-integrable' macro by Dybvig et al.
+  (lambda (x)
+    ;; Use a space in the prefix to avoid potential -Wunused-toplevel
+    ;; warning
+    (define prefix (string->symbol "% "))
+    (define (make-procedure-name name)
+      (datum->syntax name
+                     (symbol-append prefix (syntax->datum name)
+                                    '-procedure)))

 
 

-(define (load-emacs-interface)
-  (and (provided? 'debug-extensions)
-       (debug-enable 'backtrace))
-  (named-module-use! '(guile-user) '(ice-9 emacs)))
+    (syntax-case x ()
+      ((_ (name formals ...) body ...)
+       (identifier? #'name)
+       (with-syntax ((proc-name  (make-procedure-name #'name))
+                     ((args ...) (generate-temporaries #'(formals ...))))
+         #`(begin
+             (define (proc-name formals ...)
+               (fluid-let-syntax ((name (identifier-syntax proc-name)))
+                 body ...))
+             (define-syntax name
+               (lambda (x)
+                 (syntax-case x ()
+                   ((_ args ...)
+                    #'((fluid-let-syntax ((name (identifier-syntax proc-name)))
+                         (lambda (formals ...)
+                           body ...))
+                       args ...))
+                   (_
+                    (identifier? x)
+                    #'proc-name))))))))))

 
 \f
 
 
 \f
 


@@ -3370,91 +3827,6 @@ module '(ice-9 q) '(make-q q-length))}."
       (lambda () (fluid-ref using-readline?))
       (lambda (v) (fluid-set! using-readline? v)))))
 
       (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))
-

 \f
 
 ;;; {Deprecated stuff}
 \f
 
 ;;; {Deprecated stuff}


@@ -3471,8 +3843,10 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; FIXME:
 (module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 
 ;; FIXME:
 (module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 

+;; Set filename to #f to prevent reload.

 (define-module (guile-user)
 (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.
 
 ;; Remain in the `(guile)' module at compilation-time so that the
 ;; `-Wunused-toplevel' warning works as expected.