X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/cd8c35193cb2e772889f799b458497bc6e6986d1..91ee7515da0bad91330ce5c87b250d6cf12a2789:/module/ice-9/boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d488aada3..1de5edf5b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,7 +1,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
@@ -69,23 +70,6 @@
 
 (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)
@@ -98,18 +82,21 @@
       (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)
-    (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)
-    (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))
-            (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))
@@ -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))
-              ((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))
-              (apply (exception-handler) key args)))))
+              (apply (fluid-ref %exception-handler) key args)))))
 
 
 
@@ -227,9 +214,11 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)
 
 (define (warn . stuff)
-  (with-output-to-port (current-error-port)
+  (with-output-to-port (current-warning-port)
     (lambda ()
       (newline)
       (display ";;; WARNING ")
@@ -263,6 +252,50 @@ If there is no handler at all, Guile prints an error and then exits."
 
 
 
+;;; 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...) ...)
@@ -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))
+(define (module-add! module sym var)
+  (hashq-set! (%get-pre-modules-obarray) sym var))
 (define (module-define! module sym val)
   (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
     (if v
         (variable-set! v val)
-        (hashq-set! (%get-pre-modules-obarray) sym
-                    (make-variable val)))))
+        (module-add! (current-module) sym (make-variable val)))))
 (define (module-ref module sym)
   (let ((v (module-variable module sym)))
     (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
@@ -459,9 +493,8 @@ If there is no handler at all, Guile prints an error and then exits."
     ((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")
 
@@ -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)))))
 
+(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))))))))
+
+
+
+
+;;;
+;;; 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))
+
 
 
 
@@ -531,15 +818,36 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define (identity x) x)
+
+(define (compose proc . rest)
+  "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+  (if (null? rest)
+      proc
+      (let ((g (apply compose rest)))
+        (lambda args
+          (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+  "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+  (lambda args
+    (not (apply proc args))))
+
+(define (const value)
+  "Return a procedure that accepts any number of arguments and returns
+VALUE."
+  (lambda _
+    value))
+
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 
-(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)))
 
 
 
@@ -558,10 +866,12 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; properties within the object itself.
 
 (define (make-object-property)
-  (let ((prop (primitive-make-property #f)))
+  ;; Weak tables are thread-safe.
+  (let ((prop (make-weak-key-hash-table)))
     (make-procedure-with-setter
-     (lambda (obj) (primitive-property-ref prop obj))
-     (lambda (obj val) (primitive-property-set! prop obj val)))))
+     (lambda (obj) (hashq-ref prop obj))
+     (lambda (obj val) (hashq-set! prop obj val)))))
+
 
 
 
@@ -639,16 +949,13 @@ If there is no handler at all, Guile prints an error and then exits."
 
 ;; 0: type-name, 1: fields, 2: constructor
 (define record-type-vtable
-  ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
-  ;; that we need to expose the bare vtable-vtable to Scheme.
-  (make-vtable-vtable "prprpw" 0
-                      (lambda (s p)
-                        (cond ((eq? s record-type-vtable)
-                               (display "#<record-type-vtable>" p))
-                              (else
-                               (display "#<record-type " p)
-                               (display (record-type-name s) p)
-                               (display ">" p))))))
+  (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+                        (lambda (s p)
+                          (display "#<record-type " p)
+                          (display (record-type-name s) p)
+                          (display ">" p)))))
+    (set-struct-vtable-name! s 'record-type)
+    s))
 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
@@ -815,8 +1122,9 @@ If there is no handler at all, Guile prints an error and then exits."
 
 
 
-(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"))
@@ -1052,10 +1360,9 @@ If there is no handler at all, Guile prints an error and then exits."
          (thunk)))
      (lambda (k . args)
        (%start-stack tag (lambda () (apply k args)))))))
-(define-syntax start-stack
-  (syntax-rules ()
-    ((_ tag exp)
-     (%start-stack tag (lambda () exp)))))
+
+(define-syntax-rule (start-stack tag exp)
+  (%start-stack tag (lambda () exp)))
 
 
 
@@ -1074,7 +1381,7 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (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 ")
@@ -1084,71 +1391,6 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (set! %load-hook %load-announce)
 
-(define* (load name #:optional reader)
-  ;; Returns the .go file corresponding to `name'. Does not search load
-  ;; paths, only the fallback path. If the .go file is missing or out of
-  ;; date, and autocompilation is enabled, will try autocompilation, just
-  ;; as primitive-load-path does internally. primitive-load is
-  ;; unaffected. Returns #f if autocompilation failed or was disabled.
-  ;;
-  ;; NB: Unless we need to compile the file, this function should not cause
-  ;; (system base compile) to be loaded up. For that reason compiled-file-name
-  ;; partially duplicates functionality from (system base compile).
-  (define (compiled-file-name canon-path)
-    (and %compile-fallback-path
-         (string-append
-          %compile-fallback-path
-          ;; no need for '/' separator here, canon-path is absolute
-          canon-path
-          (cond ((or (null? %load-compiled-extensions)
-                     (string-null? (car %load-compiled-extensions)))
-                 (warn "invalid %load-compiled-extensions"
-                       %load-compiled-extensions)
-                 ".go")
-                (else (car %load-compiled-extensions))))))
-  (define (fresh-compiled-file-name go-path)
-    (catch #t
-      (lambda ()
-        (let* ((scmstat (stat name))
-               (gostat  (stat go-path #f)))
-          (if (and gostat
-                   (or (> (stat:mtime gostat) (stat:mtime scmstat))
-                       (and (= (stat:mtime gostat) (stat:mtime scmstat))
-                            (>= (stat:mtimensec gostat)
-                                (stat:mtimensec scmstat)))))
-              go-path
-              (begin
-                (if gostat
-                    (format (current-error-port)
-                            ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
-                            name go-path))
-                (cond
-                 (%load-should-autocompile
-                  (%warn-autocompilation-enabled)
-                  (format (current-error-port) ";;; compiling ~a\n" name)
-                  ;; This use of @ is (ironically?) boot-safe, as modules have
-                  ;; not been booted yet, so the resolve-module call in psyntax
-                  ;; doesn't try to load a module, and compile-file will be
-                  ;; treated as a function, not a macro.
-                  (let ((cfn ((@ (system base compile) compile-file) name
-                              #:env (current-module))))
-                    (format (current-error-port) ";;; compiled ~a\n" cfn)
-                    cfn))
-                 (else #f))))))
-      (lambda (k . args)
-        (format (current-error-port)
-                ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
-                name k args)
-        #f)))
-  (with-fluids ((current-reader reader))
-    (let ((cfn (and=> (and=> (false-if-exception (canonicalize-path name))
-                             compiled-file-name)
-                      fresh-compiled-file-name)))
-      (if cfn
-          (load-compiled cfn)
-          (start-stack 'load-stack
-                       (primitive-load name))))))
-
 
 
 ;;; {Reader Extensions}
@@ -1156,8 +1398,7 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;; 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?)
@@ -1325,7 +1566,7 @@ If there is no handler at all, Guile prints an error and then exits."
     ((define-record-type
        (lambda (x)
          (define (make-id scope . fragments)
-           (datum->syntax #'scope
+           (datum->syntax scope
                           (apply symbol-append
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))
@@ -1802,33 +2043,6 @@ 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))
 
-;; 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.
-;;
-;; 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)))
-
 
 
 ;;; {Module-based Loading}
@@ -1847,22 +2061,6 @@ If there is no handler at all, Guile prints an error and then exits."
                     (set-current-module outer-module)
                     (set! outer-module #f)))))
 
-(define basic-load load)
-
-(define* (load-module filename #:optional reader)
-  (save-module-excursion
-   (lambda ()
-     (let ((oldname (and (current-load-port)
-                         (port-filename (current-load-port)))))
-       (basic-load (if (and oldname
-                            (> (string-length filename) 0)
-                            (not (char=? (string-ref filename 0) #\/))
-                            (not (string=? (dirname oldname) ".")))
-                       (string-append (dirname oldname) "/" filename)
-                       filename)
-                   reader)))))
-
-
 
 
 ;;; {MODULE-REF -- exported}
@@ -1926,25 +2124,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.
-        (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
 ;;
-;; 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)
-  (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)))
 
 
 
@@ -2120,6 +2322,10 @@ If there is no handler at all, Guile prints an error and then exits."
     (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)
@@ -2253,6 +2459,7 @@ If there is no handler at all, Guile prints an error and then exits."
   (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
@@ -2400,10 +2607,6 @@ If there is no handler at all, Guile prints an error and then exits."
               (error "expected list of integers for version"))
           (set-module-version! module version)
           (set-module-version! (module-public-interface module) version)))
-    (if (pair? duplicates)
-        (let ((handlers (lookup-duplicates-handlers duplicates)))
-          (set-module-duplicates-handlers! module handlers)))
-
     (let ((imports (resolve-imports imports)))
       (call-with-deferred-observers
        (lambda ()
@@ -2423,7 +2626,12 @@ If there is no handler at all, Guile prints an error and then exits."
              (error "expected re-exports to be a list of symbols or symbol pairs"))
          ;; FIXME
          (if (not (null? autoloads))
-             (apply module-autoload! module 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))
@@ -2435,107 +2643,6 @@ If there is no handler at all, Guile prints an error and then exits."
     (run-hook module-defined-hook module)
     module))
 
-(define (process-define-module args)
-  (define (missing kw)
-    (error "missing argument to define-module keyword" kw))
-  (define (unrecognized arg)
-    (error "unrecognized define-module argument" arg))
-
-  (let ((name (car args))
-        (filename #f)
-        (pure? #f)
-        (version #f)
-        (system? #f)
-        (duplicates '())
-        (transformer #f))
-    (let loop ((kws (cdr args))
-               (imports '())
-               (exports '())
-               (re-exports '())
-               (replacements '())
-               (autoloads '()))
-      (if (null? kws)
-          (define-module* name
-            #:filename filename #:pure pure? #:version version
-            #:duplicates duplicates #:transformer transformer
-            #:imports (reverse! imports)
-            #:exports exports
-            #:re-exports re-exports
-            #:replacements replacements
-            #:autoloads autoloads)
-          (case (car kws)
-            ((#:use-module #:use-syntax)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (cond
-              ((equal? (cadr kws) '(ice-9 syncase))
-               (issue-deprecation-warning
-                "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
-               (loop (cddr kws)
-                     imports exports re-exports replacements autoloads))
-              (else
-               (let ((iface-spec (cadr kws)))
-                 (if (eq? (car kws) #:use-syntax)
-                     (set! transformer iface-spec))
-                 (loop (cddr kws)
-                       (cons iface-spec imports) exports re-exports
-                       replacements autoloads)))))
-            ((#:autoload)
-             (or (and (pair? (cdr kws)) (pair? (cddr kws)))
-                 (missing (car kws)))
-             (let ((name (cadr kws))
-                   (bindings (caddr kws)))
-               (loop (cdddr kws)
-                     imports exports re-exports
-                     replacements (cons* name bindings autoloads))))
-            ((#:no-backtrace)
-             ;; FIXME: deprecate?
-             (set! system? #t)
-             (loop (cdr kws)
-                   imports exports re-exports replacements autoloads))
-            ((#:pure)
-             (set! pure? #t)
-             (loop (cdr kws)
-                   imports exports re-exports replacements autoloads))
-            ((#:version)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (set! version (cadr kws))
-             (loop (cddr kws)
-                   imports exports re-exports replacements autoloads))
-            ((#:duplicates)
-             (if (not (pair? (cdr kws)))
-                 (missing (car kws)))
-             (set! duplicates (cadr kws))
-             (loop (cddr kws)
-                   imports exports re-exports replacements autoloads))
-            ((#:export #:export-syntax)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (loop (cddr kws)
-                   imports (append exports (cadr kws)) re-exports
-                   replacements autoloads))
-            ((#:re-export #:re-export-syntax)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (loop (cddr kws)
-                   imports exports (append re-exports (cadr kws))
-                   replacements autoloads))
-            ((#:replace #:replace-syntax)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (loop (cddr kws)
-                   imports exports re-exports
-                   (append replacements (cadr kws)) autoloads))
-            ((#:filename)
-             (or (pair? (cdr kws))
-                 (missing (car kws)))
-             (set! filename (cadr kws))
-             (loop (cddr kws)
-                   imports exports re-exports replacements autoloads))
-            (else
-             (unrecognized kws)))))))
-
 ;; `module-defined-hook' is a hook that is run whenever a new module
 ;; is defined.  Its members are called with one argument, the new
 ;; module.
@@ -2613,7 +2720,7 @@ module '(ice-9 q) '(make-q q-length))}."
                    ;; Here we could allow some other search strategy (other than
                    ;; primitive-load-path), for example using versions encoded
                    ;; into the file system -- but then we would have to figure
-                   ;; out how to locate the compiled file, do autocompilation,
+                   ;; out how to locate the compiled file, do auto-compilation,
                    ;; etc. Punt for now, and don't use versions when locating
                    ;; the file.
                    (primitive-load-path (in-vicinity dir-hint name) #f)
@@ -2690,11 +2797,9 @@ module '(ice-9 q) '(make-q q-length))}."
                      flags)
            (interface options)
            (interface)))
-       (define-syntax option-set!
-         (syntax-rules ()
-           ((_ opt val)
-            (eval-when (eval load compile expand)
-              (options (append (options) (list 'opt val)))))))))))
+       (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
@@ -2728,17 +2833,109 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
+;;; {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* ...)))))))
+
+
+;;;
+;;; 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"))
+
+
+
+;;;
+;;; Warnings.
+;;;
+
+(define current-warning-port
+  (make-parameter (current-error-port)
+                  (lambda (x)
+                    (if (output-port? x)
+                        x
+                        (error "expected an output port" x)))))
+
+
+
+
 ;;; {Running Repls}
 ;;;
 
-(define *repl-stack* (make-fluid))
+(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.
 ;;
 (define (batch-mode?)
-  (null? (or (fluid-ref *repl-stack*) '())))
+  (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
@@ -2777,7 +2974,26 @@ module '(ice-9 q) '(make-q q-length))}."
 (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))))
@@ -2815,13 +3031,11 @@ module '(ice-9 q) '(make-q q-length))}."
               (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
@@ -2834,12 +3048,14 @@ module '(ice-9 q) '(make-q q-length))}."
                          ((_ . 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)
-              #t)))))))
+            (lambda (k . args)
+              (if (null? args)
+                  #t
+                  (apply values args)))))))))
 
 
 
@@ -2915,15 +3131,15 @@ module '(ice-9 q) '(make-q q-length))}."
          #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
         ((#:use-module (name name* ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
-         (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+         (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 (cons #'((name name* ...)) imp) exp rex rep aut)))
+            . #,(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
-                (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+                #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
                 exp rex rep aut))
         ((#:export (ex ...) . args)
          (parse #'args imp #`(#,@exp ex ...) rex rep aut))
@@ -2948,8 +3164,13 @@ module '(ice-9 q) '(make-q q-length))}."
        (and-map symbol? (syntax->datum #'(name name* ...)))
        (with-syntax (((quoted-arg ...)
                       (parse #'(arg ...) '() '() '() '() '()))
-                     (filename (assq-ref (or (syntax-source x) '())
-                                         'filename)))
+                     ;; Ideally the filename is either a string or #f;
+                     ;; this hack is to work around a case in which
+                     ;; port-filename returns a symbol (`socket') for
+                     ;; sockets.
+                     (filename (let ((f (assq-ref (or (syntax-source x) '())
+                                                  'filename)))
+                                 (and (string? f) f))))
          #'(eval-when (eval load compile expand)
              (let ((m (define-module* '(name name* ...)
                         #:filename filename quoted-arg ...)))
@@ -3014,21 +3235,10 @@ module '(ice-9 q) '(make-q q-length))}."
              (process-use-modules (list quoted-args ...))
              *unspecified*))))))
 
-(define-syntax use-syntax
-  (syntax-rules ()
-    ((_ spec ...)
-     (begin
-       (eval-when (eval load compile expand)
-         (issue-deprecation-warning
-          "`use-syntax' is deprecated. Please contact guile-devel for more info."))
-       (use-modules spec ...)))))
-
 (include-from-path "ice-9/r6rs-libraries")
 
-(define-syntax define-private
-  (syntax-rules ()
-    ((_ foo bar)
-     (define foo bar))))
+(define-syntax-rule (define-private foo bar)
+  (define foo bar))
 
 (define-syntax define-public
   (syntax-rules ()
@@ -3039,18 +3249,14 @@ module '(ice-9 q) '(make-q q-length))}."
        (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.
-(define-syntax λ
-  (syntax-rules ()
-    ((_ formals body ...)
-     (lambda formals body ...))))
+(define-syntax-rule (λ formals body ...)
+  (lambda formals body ...))
 
 
 ;; Export a local variable
@@ -3073,6 +3279,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)))
+                  ;; FIXME: use a bit on variables instead of object
+                  ;; properties.
                   (set-object-property! var 'replace #t)
                   (module-add! public-i external-name var)))
               names)))
@@ -3107,41 +3315,29 @@ module '(ice-9 q) '(make-q q-length))}."
                          (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 ...))
 
 
 
@@ -3149,8 +3345,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 
 (define* (make-mutable-parameter init #:optional (converter identity))
-  (let ((fluid (make-fluid)))
-    (fluid-set! fluid (converter init))
+  (let ((fluid (make-fluid (converter init))))
     (case-lambda
       (() (fluid-ref fluid))
       ((val) (fluid-set! fluid (converter val))))))
@@ -3193,7 +3388,7 @@ module '(ice-9 q) '(make-q q-length))}."
                  #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
@@ -3215,7 +3410,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
-             (format (current-error-port)
+             (format (current-warning-port)
                      "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
                      (module-name module)
                      (module-name int2)
@@ -3266,6 +3461,151 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
+;;; {`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))))))))
+
+
+
 ;;; {`cond-expand' for SRFI-0 support.}
 ;;;
 ;;; This syntactic form expands into different commands or
@@ -3308,6 +3648,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-23  ;; `error` procedure
+    srfi-39  ;; parameterize
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
     ))
@@ -3399,6 +3741,44 @@ module '(ice-9 q) '(make-q q-length))}."
                          x)))))
 
 
+;;; Defining transparently inlinable procedures
+;;;
+
+(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)))
+
+    (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 ...)
+               (syntax-parameterize ((name (identifier-syntax proc-name)))
+                 body ...))
+             (define-syntax-parameter name
+               (lambda (x)
+                 (syntax-case x ()
+                   ((_ args ...)
+                    #'((syntax-parameterize ((name (identifier-syntax proc-name)))
+                         (lambda (formals ...)
+                           body ...))
+                       args ...))
+                   (_
+                    (identifier? x)
+                    #'proc-name))))))))))
+
+
 
 (define using-readline?
   (let ((using-readline? (make-fluid)))
@@ -3422,8 +3802,10 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; FIXME:
 (module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 
+;; Set filename to #f to prevent reload.
 (define-module (guile-user)
-  #:autoload (system base compile) (compile))
+  #:autoload (system base compile) (compile compile-file)
+  #:filename #f)
 
 ;; Remain in the `(guile)' module at compilation-time so that the
 ;; `-Wunused-toplevel' warning works as expected.