Merge remote-tracking branch 'origin/stable-2.0'

[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 800410c..1de5edf 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,2011
-;;;; 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...) ...)


@@ -460,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")
 


@@ -473,11 +505,150 @@ 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 define-once
-  (syntax-rules ()
-    ((_ sym val)
-     (define sym
-       (if (module-locally-bound? (current-module) 'sym) sym val)))))
+(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
 
 
 \f
 


@@ -497,7 +668,7 @@ If there is no handler at all, Guile prints an error and then exits."
           (let ((filename (or (cadr source) "<unnamed port>"))
                 (line (caddr source))
                 (col (cdddr source)))
           (let ((filename (or (cadr source) "<unnamed port>"))
                 (line (caddr source))
                 (col (cdddr source)))

-            (format port "~a:~a:~a: " filename line col))
+            (format port "~a:~a:~a: " filename (1+ line) col))

           (format port "ERROR: "))))
 
   (set! set-exception-printer!
           (format port "ERROR: "))))
 
   (set! set-exception-printer!


@@ -562,6 +733,9 @@ If there is no handler at all, Guile prints an error and then exits."
              (_ (default-printer)))
            args))
 
              (_ (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! 'goops-error scm-error-printer)
   (set-exception-printer! 'host-not-found scm-error-printer)
   (set-exception-printer! 'keyword-argument-error scm-error-printer)


@@ -581,7 +755,9 @@ If there is no handler at all, Guile prints an error and then exits."
   (set-exception-printer! 'wrong-number-of-args scm-error-printer)
   (set-exception-printer! 'wrong-type-arg 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! 'syntax-error syntax-error-printer)
+
+  (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))

 
 
 \f
 
 
 \f


@@ -668,12 +844,10 @@ 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
 


@@ -692,17 +866,11 @@ VALUE."
 ;; properties within the object itself.
 
 (define (make-object-property)
 ;; properties within the object itself.
 
 (define (make-object-property)

-  (define-syntax with-mutex
-    (syntax-rules ()
-      ((_ lock exp)
-       (dynamic-wind (lambda () (lock-mutex lock))
-                     (lambda () exp)
-                     (lambda () (unlock-mutex lock))))))
-  (let ((prop (make-weak-key-hash-table))
-        (lock (make-mutex)))
+  ;; Weak tables are thread-safe.
+  (let ((prop (make-weak-key-hash-table)))

     (make-procedure-with-setter
     (make-procedure-with-setter

-     (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
-     (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+     (lambda (obj) (hashq-ref prop obj))
+     (lambda (obj val) (hashq-set! prop obj val)))))

 
 
 \f
 
 
 \f


@@ -781,16 +949,13 @@ VALUE."
 
 ;; 0: type-name, 1: fields, 2: constructor
 (define record-type-vtable
 
 ;; 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))))
 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))


@@ -1195,10 +1360,9 @@ VALUE."
          (thunk)))
      (lambda (k . args)
        (%start-stack tag (lambda () (apply k args)))))))
          (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)))

 
 \f
 
 
 \f
 


@@ -1217,7 +1381,7 @@ VALUE."
 
 (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 ")


@@ -1234,8 +1398,7 @@ VALUE."
 ;;; 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?)


@@ -1403,7 +1566,7 @@ VALUE."
     ((define-record-type
        (lambda (x)
          (define (make-id scope . fragments)
     ((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)))
                           (apply symbol-append
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))


@@ -1880,33 +2043,6 @@ VALUE."
 (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))
 

-;; 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)))
-

 \f
 
 ;;; {Module-based Loading}
 \f
 
 ;;; {Module-based Loading}


@@ -2471,10 +2607,6 @@ VALUE."
               (error "expected list of integers for version"))
           (set-module-version! module version)
           (set-module-version! (module-public-interface module) version)))
               (error "expected list of integers for version"))
           (set-module-version! module version)
           (set-module-version! (module-public-interface module) version)))

-    (if (pair? duplicates)
-        (let ((handlers (lookup-duplicates-handlers duplicates)))
-          (set-module-duplicates-handlers! module handlers)))
-

     (let ((imports (resolve-imports imports)))
       (call-with-deferred-observers
        (lambda ()
     (let ((imports (resolve-imports imports)))
       (call-with-deferred-observers
        (lambda ()


@@ -2494,7 +2626,12 @@ VALUE."
              (error "expected re-exports to be a list of symbols or symbol pairs"))
          ;; FIXME
          (if (not (null? autoloads))
              (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))
 
     (if transformer
         (if (and (pair? transformer) (list-of symbol? transformer))


@@ -2660,11 +2797,9 @@ module '(ice-9 q) '(make-q q-length))}."
                      flags)
            (interface options)
            (interface)))
                      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
 
 (define-option-interface
   (debug-options-interface


@@ -2698,17 +2833,109 @@ 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))
+(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?)
 
 ;; 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
 
 ;; 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


@@ -2747,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?))
 (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))))


@@ -2785,13 +3031,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


@@ -2806,10 +3050,12 @@ module '(ice-9 q) '(make-q q-length))}."
                          (_
                           #'(lambda ()
                               (abort-to-prompt continue-tag))))))
                          (_
                           #'(lambda ()
                               (abort-to-prompt continue-tag))))))

-                   (do () ((not cond)) body ...))
+                   (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


@@ -2885,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* ...))))
          #`(#: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* ...)
         ((#: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
         ((#: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))
                 exp rex rep aut))
         ((#:export (ex ...) . args)
          (parse #'args imp #`(#,@exp ex ...) rex rep aut))


@@ -2989,21 +3235,10 @@ 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 ...)))))
-

 (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 ()


@@ -3014,18 +3249,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


@@ -3048,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)))
                 (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)))


@@ -3082,39 +3315,29 @@ 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-rule (export 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 (re-export name ...)
+  (eval-when (eval load compile expand)
+    (call-with-deferred-observers
+     (lambda ()
+       (module-re-export! (current-module) '(name ...))))))

 
 

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

 
 

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

 
 

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

 
 \f
 
 
 \f
 


@@ -3122,8 +3345,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 
 (define* (make-mutable-parameter init #:optional (converter identity))
 ;;;
 
 (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))))))
     (case-lambda
       (() (fluid-ref fluid))
       ((val) (fluid-set! fluid (converter val))))))


@@ -3166,7 +3388,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


@@ -3188,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
     (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)


@@ -3242,7 +3464,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; {`load'.}
 ;;;
 ;;; Load is tricky when combined with relative paths, compilation, and
 ;;; {`load'.}
 ;;;
 ;;; Load is tricky when combined with relative paths, compilation, and

-;;; the filesystem.  If a path is relative, what is it relative to?  The
+;;; 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.
 ;;; 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.


@@ -3260,9 +3482,18 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define %auto-compilation-options
   ;; Default `compile-file' option when auto-compiling.
 
 (define %auto-compilation-options
   ;; Default `compile-file' option when auto-compiling.

-  '(#:warnings (unbound-variable arity-mismatch)))
+  '(#:warnings (unbound-variable arity-mismatch format)))

 
 (define* (load-in-vicinity dir path #:optional reader)
 
 (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
   ;; 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


@@ -3274,11 +3505,12 @@ module '(ice-9 q) '(make-q q-length))}."
   ;; partially duplicates functionality from (system base compile).
   ;;
   (define (compiled-file-name canon-path)
   ;; 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
     (and %compile-fallback-path
          (string-append
           %compile-fallback-path

-          ;; no need for '/' separator here, canon-path is absolute
-          canon-path
+          (canonical->suffix canon-path)

           (cond ((or (null? %load-compiled-extensions)
                      (string-null? (car %load-compiled-extensions)))
                  (warn "invalid %load-compiled-extensions"
           (cond ((or (null? %load-compiled-extensions)
                      (string-null? (car %load-compiled-extensions)))
                  (warn "invalid %load-compiled-extensions"


@@ -3290,7 +3522,8 @@ module '(ice-9 q) '(make-q q-length))}."
     (catch #t
       (lambda ()
         (let* ((scmstat (stat name))
     (catch #t
       (lambda ()
         (let* ((scmstat (stat name))

-               (gostat  (stat go-path #f)))
+               (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))
           (if (and gostat
                    (or (> (stat:mtime gostat) (stat:mtime scmstat))
                        (and (= (stat:mtime gostat) (stat:mtime scmstat))


@@ -3299,13 +3532,13 @@ module '(ice-9 q) '(make-q q-length))}."
               go-path
               (begin
                 (if gostat
               go-path
               (begin
                 (if gostat

-                    (format (current-error-port)
+                    (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)
                             ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
                             name go-path))
                 (cond
                  (%load-should-auto-compile
                   (%warn-auto-compilation-enabled)

-                  (format (current-error-port) ";;; compiling ~a\n" name)
+                  (format (current-warning-port) ";;; compiling ~a\n" name)

                   (let ((cfn
                          ((module-ref
                                (resolve-interface '(system base compile))
                   (let ((cfn
                          ((module-ref
                                (resolve-interface '(system base compile))


@@ -3313,13 +3546,19 @@ module '(ice-9 q) '(make-q q-length))}."
                               name
                               #:opts %auto-compilation-options
                               #:env (current-module))))
                               name
                               #:opts %auto-compilation-options
                               #:env (current-module))))

-                    (format (current-error-port) ";;; compiled ~a\n" cfn)
+                    (format (current-warning-port) ";;; compiled ~a\n" cfn)

                     cfn))
                  (else #f))))))
       (lambda (k . args)
                     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)
+        (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)
         #f)))
 
   (define (absolute-path? path)


@@ -3332,7 +3571,10 @@ module '(ice-9 q) '(make-q q-length))}."
                         (and go-path
                              (fresh-compiled-file-name abs-path go-path)))))))
       (if cfn
                         (and go-path
                              (fresh-compiled-file-name abs-path go-path)))))))
       (if cfn

-          (load-compiled cfn)
+          (begin
+            (if %load-hook
+                (%load-hook abs-path))
+            (load-compiled cfn))

           (start-stack 'load-stack
                        (primitive-load abs-path)))))
   
           (start-stack 'load-stack
                        (primitive-load abs-path)))))
   


@@ -3405,8 +3647,9 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-4   ;; homogenous numeric vectors
     srfi-6   ;; open-input-string etc, in the guile core
     srfi-13  ;; string library
     srfi-4   ;; homogenous numeric vectors
     srfi-6   ;; open-input-string etc, in the guile core
     srfi-13  ;; string library

-    srfi-23  ;; `error` procedure

     srfi-14  ;; character sets
     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
     ))


@@ -3521,13 +3764,15 @@ module '(ice-9 q) '(make-q q-length))}."
                      ((args ...) (generate-temporaries #'(formals ...))))
          #`(begin
              (define (proc-name formals ...)
                      ((args ...) (generate-temporaries #'(formals ...))))
          #`(begin
              (define (proc-name formals ...)

-               body ...)
-             (define-syntax name
+               (syntax-parameterize ((name (identifier-syntax proc-name)))
+                 body ...))
+             (define-syntax-parameter name

                (lambda (x)
                  (syntax-case x ()
                    ((_ args ...)
                (lambda (x)
                  (syntax-case x ()
                    ((_ args ...)

-                    #'((lambda (formals ...)
-                         body ...)
+                    #'((syntax-parameterize ((name (identifier-syntax proc-name)))
+                         (lambda (formals ...)
+                           body ...))

                        args ...))
                    (_
                     (identifier? x)
                        args ...))
                    (_
                     (identifier? x)