merge from 1.8 branch

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

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 5314d7d..0f56f98 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -339,7 +339,7 @@
 
 (define (environment-module env)
   (let ((closure (and (pair? env) (car (last-pair env)))))
-    (and closure (procedure-property closure 'module))))
+    (and closure (eval-closure-module closure))))
 
 \f
 
@@ -1635,17 +1635,19 @@
 
 (define basic-load load)
 
-(define (load-module filename)
+(define (load-module filename . 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))))))
+       (apply basic-load
+             (if (and oldname
+                      (> (string-length filename) 0)
+                      (not (char=? (string-ref filename 0) #\/))
+                      (not (string=? (dirname oldname) ".")))
+                 (string-append (dirname oldname) "/" filename)
+                 filename)
+             reader)))))
 
 
 \f
@@ -2037,6 +2039,7 @@
               (exports '())
               (re-exports '())
               (replacements '()))
+
       (if (null? kws)
          (call-with-deferred-observers
           (lambda ()
@@ -2133,8 +2136,11 @@
                  (let ((i (module-public-interface (resolve-module name))))
                    (if (not i)
                        (error "missing interface for module" name))
-                   ;; Replace autoload-interface with interface
-                   (set-car! (memq a (module-uses module)) i)
+                   (let ((autoload (memq a (module-uses module))))
+                     ;; Replace autoload-interface with actual interface if
+                     ;; that has not happened yet.
+                     (if (pair? autoload)
+                         (set-car! autoload i)))
                    (module-local-variable i sym))))))
     (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
                        '() (make-weak-value-hash-table 31) 0)))
@@ -2177,7 +2183,8 @@
                            (load-file load-compiled full)))
                      ((%search-load-path file)
                       => (lambda (full)
-                           (load-file primitive-load full))))))
+                           (with-fluids ((current-reader #f))
+                             (load-file primitive-load full)))))))
            (lambda () (set-autoloaded! dir-hint name didit)))
           didit))))
 
@@ -2350,36 +2357,20 @@
             (catch #t
 
                    (lambda ()
-                     (lazy-catch #t
-                                 (lambda ()
-                                   (call-with-unblocked-asyncs
-                                    (lambda ()
-                                      (with-traps
-                                       (lambda ()
-                                         (first)
-
-                                         ;; This line is needed because mark
-                                         ;; doesn't do closures quite right.
-                                         ;; Unreferenced locals should be
-                                         ;; collected.
-                                         ;;
-                                         (set! first #f)
-                                         (let loop ((v (thunk)))
-                                           (loop (thunk)))
-                                         #f)))))
-
-                                 ;; Note that having just
-                                 ;; `lazy-handler-dispatch' here is
-                                 ;; connected with the mechanism that
-                                 ;; produces a nice backtrace upon
-                                 ;; error.  If, for example, this is
-                                 ;; replaced with (lambda args (apply
-                                 ;; lazy-handler-dispatch args)), the
-                                 ;; stack cutting (in save-stack)
-                                 ;; goes wrong and ends up saving no
-                                 ;; stack at all, so there is no
-                                 ;; backtrace.
-                                 lazy-handler-dispatch))
+                     (call-with-unblocked-asyncs
+                      (lambda ()
+                        (with-traps
+                         (lambda ()
+                           (first)
+
+                           ;; This line is needed because mark
+                           ;; doesn't do closures quite right.
+                           ;; Unreferenced locals should be
+                           ;; collected.
+                           (set! first #f)
+                           (let loop ((v (thunk)))
+                             (loop (thunk)))
+                           #f)))))
 
                    (lambda (key . args)
                      (case key
@@ -2424,7 +2415,18 @@
                           (cond ((= (length args) 4)
                                  (apply handle-system-error key args))
                                 (else
-                                 (apply bad-throw key args))))))))))
+                                 (apply bad-throw key args)))))))
+
+                   ;; Note that having just `lazy-handler-dispatch'
+                   ;; here is connected with the mechanism that
+                   ;; produces a nice backtrace upon error.  If, for
+                   ;; example, this is replaced with (lambda args
+                   ;; (apply lazy-handler-dispatch args)), the stack
+                   ;; cutting (in save-stack) goes wrong and ends up
+                   ;; saving no stack at all, so there is no
+                   ;; backtrace.
+                   lazy-handler-dispatch)))
+
        (if next (loop next) status)))
     (set! set-batch-mode?! (lambda (arg)
                             (cond (arg
@@ -2537,7 +2539,7 @@
     (display prompt)
     (force-output)
     (run-hook before-read-hook)
-    (read (current-input-port))))
+    ((or (fluid-ref current-reader) read) (current-input-port))))
 
 (define (scm-style-repl)
 
@@ -3222,7 +3224,7 @@
 ;;;
 ;;; Currently, the following feature identifiers are supported:
 ;;;
-;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14
+;;;   guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
 ;;;
 ;;; Remember to update the features list when adding more SRFIs.
 ;;;
@@ -3237,6 +3239,7 @@
     srfi-13  ;; string library
     srfi-14  ;; character sets
     srfi-55  ;; require-extension
+    srfi-61  ;; general cond clause
     ))
 
 ;; This table maps module public interfaces to the list of features.