* boot-9.scm (try-using-libtool-name): Fix check on dlname to make

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

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 423fd21..8469607 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
 ;;; installed-scm-file
 

-;;;;   Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+;;;;   Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.

 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by


@@ -251,11 +251,42 @@
               (case handle-delim
                   ((trim peek concat) (join-substrings))
                   ((split) (cons (join-substrings) terminator))
               (case handle-delim
                   ((trim peek concat) (join-substrings))
                   ((split) (cons (join-substrings) terminator))

+
+

                   (else (error "unexpected handle-delim value: "
                                handle-delim)))))))))
                   (else (error "unexpected handle-delim value: "
                                handle-delim)))))))))

-    
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'.  If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned.  If `concat', the string is
+;;; returned with the trailing newline intact.  If `peek', the newline
+;;; is left in the input port buffer and the string is returned.  If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+

 (define (read-line . args)
 (define (read-line . args)

-  (apply read-delimited scm-line-incrementors args))
+  (let* ((port         (if (null? args)
+                           (current-input-port)
+                           (car args)))
+        (handle-delim  (if (> (length args) 1)
+                           (cadr args)
+                           'trim))
+        (line/delim    (%read-line port))
+        (line          (car line/delim))
+        (delim         (cdr line/delim)))
+    (case handle-delim
+      ((trim) line)
+      ((split) line/delim)
+      ((concat) (if (and (string? line) (char? delim))
+                   (string-append line (string delim))
+                   line))
+      ((peek) (if (char? delim)
+                 (unread-char delim port))
+             line)
+      (else
+       (error "unexpected handle-delim value: " handle-delim)))))

 
 \f
 ;;; {Arrays}
 
 \f
 ;;; {Arrays}


@@ -463,7 +494,32 @@
 
 
 \f
 
 
 \f

-;;; {and-map, or-map, and map-in-order}
+;;; {Multiple return values}
+
+(define *values-rtd*
+  (make-record-type "values"
+                   '(values)))
+
+(define values
+  (let ((make-values (record-constructor *values-rtd*)))
+    (lambda x
+      (if (and (not (null? x))
+              (null? (cdr x)))
+         (car x)
+         (make-values x)))))
+
+(define call-with-values
+  (let ((access-values (record-accessor *values-rtd* 'values))
+       (values-predicate? (record-predicate *values-rtd*)))
+    (lambda (producer consumer)
+      (let ((result (producer)))
+       (if (values-predicate? result)
+           (apply consumer (access-values result))
+           (consumer result))))))
+
+
+\f
+;;; {and-map and or-map}

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


@@ -496,33 +552,54 @@
        (and (not (null? l))
             (loop (f (car l)) (cdr l))))))
 
        (and (not (null? l))
             (loop (f (car l)) (cdr l))))))
 

-;; map-in-order
-;;
-;; Like map, but guaranteed to process the list in order.
-;;
-(define (map-in-order fn l)
-  (if (null? l)
-      '()
-      (cons (fn (car l))
-           (map-in-order fn (cdr l)))))
-

 \f
 ;;; {Hooks}
 \f
 ;;; {Hooks}

+;;;
+;;; Warning: Hooks are now first class objects and add-hook! and remove-hook!
+;;; procedures.  This interface is only provided for backward compatibility
+;;; and will be removed.
+;;;
+(if (not (defined? 'new-add-hook!))
+    (begin
+      (define new-add-hook! add-hook!)
+      (define new-remove-hook! remove-hook!)))
+

 (define (run-hooks hook)
 (define (run-hooks hook)

-  (for-each (lambda (thunk) (thunk)) hook))
+  (if (and (pair? hook) (eq? (car hook) 'hook))
+      (run-hook hook)
+      (for-each (lambda (thunk) (thunk)) hook)))

 
 (define add-hook!
 
 (define add-hook!

-  (procedure->macro
+  (procedure->memoizing-macro

     (lambda (exp env)
     (lambda (exp env)

-      `(let ((thunk ,(caddr exp)))
-        (if (not (memq thunk ,(cadr exp)))
-            (set! ,(cadr exp)
-                  (cons thunk ,(cadr exp))))))))
+      (let ((hook (local-eval (cadr exp) env)))
+       (if (and (pair? hook) (eq? (car hook) 'hook))
+           `(new-add-hook! ,@(cdr exp))
+           (begin
+             (display "Warning: Old style hooks\n" (current-error-port))
+             `(let ((thunk ,(caddr exp)))
+                (if (not (memq thunk ,(cadr exp)))
+                    (set! ,(cadr exp)
+                          (cons thunk ,(cadr exp)))))))))))
+
+(define remove-hook!
+  (procedure->memoizing-macro
+    (lambda (exp env)
+      (let ((hook (local-eval (cadr exp) env)))
+       (if (and (pair? hook) (eq? (car hook) 'hook))
+           `(new-remove-hook! ,@(cdr exp))
+           (begin
+             (display "Warning: Old style hooks\n" (current-error-port))
+             `(let ((thunk ,(caddr exp)))
+                    (set! ,(cadr exp)
+                          (delq! thunk ,(cadr exp))))))))))

 
 \f
 ;;; {Files}
 
 \f
 ;;; {Files}

-;;; !!!! these should be implemented using Tcl commands, not fports.

 ;;;
 ;;;

+;;; If no one can explain this comment to me by 31 Jan 1998, I will
+;;; assume it is meaningless and remove it. -twp
+;;;   !!!! these should be implemented using Tcl commands, not fports.

 
 (define (feature? feature)
   (and (memq feature *features*) #t))
 
 (define (feature? feature)
   (and (memq feature *features*) #t))


@@ -847,7 +924,7 @@
 ;;; {Transcendental Functions}
 ;;;
 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
 ;;; {Transcendental Functions}
 ;;;
 ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.

-;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
+;;; Written by Jerry D. Hedden, (C) FSF.

 ;;; See the file `COPYING' for terms applying to this program.
 ;;;
 
 ;;; See the file `COPYING' for terms applying to this program.
 ;;;
 


@@ -981,6 +1058,21 @@
              (loop (cons (read-component) reversed-path)))
            (reverse reversed-path))))))
 
              (loop (cons (read-component) reversed-path)))
            (reverse reversed-path))))))
 

+(define (read-path-list-notation-warning slash port)
+  (if (not (getenv "GUILE_HUSH"))
+      (begin
+       (display "warning: obsolete `#/' list notation read from "
+                (current-error-port))
+       (display (port-filename port) (current-error-port))
+       (display "; see guile-core/NEWS." (current-error-port))
+       (newline (current-error-port))
+       (display "         Set the GUILE_HUSH environment variable to disable this warning."
+                (current-error-port))
+       (newline (current-error-port))))
+  (read-hash-extend #\/ read-path-list-notation)
+  (read-path-list-notation slash port))
+
+

 (read-hash-extend #\' (lambda (c port)
                        (read port)))
 (read-hash-extend #\. (lambda (c port)
 (read-hash-extend #\' (lambda (c port)
                        (read port)))
 (read-hash-extend #\. (lambda (c port)


@@ -994,8 +1086,8 @@
        (for-each (lambda (char template)
                    (read-hash-extend char
                                      (make-array-proc template)))
        (for-each (lambda (char template)
                    (read-hash-extend char
                                      (make-array-proc template)))

-                 '(#\b #\a #\u #\e #\s #\i #\c)
-                 '(#t  #\a 1   -1  1.0 1/3 0+i)))
+                 '(#\b #\a #\u #\e #\s #\i #\c #\y   #\h)
+                 '(#t  #\a 1   -1  1.0 1/3 0+i #\nul s)))

       (let ((array-proc (lambda (c port)
                          (read:array c port))))
        (for-each (lambda (char) (read-hash-extend char array-proc))
       (let ((array-proc (lambda (c port)
                          (read:array c port))))
        (for-each (lambda (char) (read-hash-extend char array-proc))


@@ -1003,7 +1095,7 @@
 
 ;; pushed to the beginning of the alist since it's used more than the
 ;; others at present.
 
 ;; pushed to the beginning of the alist since it's used more than the
 ;; others at present.

-(read-hash-extend #\/ read-path-list-notation)
+(read-hash-extend #\/ read-path-list-notation-warning)

 
 (define (read:array digit port)
   (define chr0 (char->integer #\0))
 
 (define (read:array digit port)
   (define chr0 (char->integer #\0))


@@ -1269,7 +1361,10 @@
 (define set-module-uses! (record-modifier module-type 'uses))
 (define module-binder (record-accessor module-type 'binder))
 (define set-module-binder! (record-modifier module-type 'binder))
 (define set-module-uses! (record-modifier module-type 'uses))
 (define module-binder (record-accessor module-type 'binder))
 (define set-module-binder! (record-modifier module-type 'binder))

+
+;; NOTE: This binding is used in libguile/modules.c.

 (define module-eval-closure (record-accessor module-type 'eval-closure))
 (define module-eval-closure (record-accessor module-type 'eval-closure))

+

 (define set-module-eval-closure! (record-modifier module-type 'eval-closure))
 (define module-transformer (record-accessor module-type 'transformer))
 (define set-module-transformer! (record-modifier module-type 'transformer))
 (define set-module-eval-closure! (record-modifier module-type 'eval-closure))
 (define module-transformer (record-accessor module-type 'transformer))
 (define set-module-transformer! (record-modifier module-type 'transformer))


@@ -1579,7 +1674,9 @@
 
 
 ;; the-module
 
 
 ;; the-module

-;; 
+;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;

 (define the-module #f)
 
 ;; scm:eval-transformer
 (define the-module #f)
 
 ;; scm:eval-transformer


@@ -1590,6 +1687,8 @@
 ;;
 ;; set the current module as viewed by the normalizer.
 ;;
 ;;
 ;; set the current module as viewed by the normalizer.
 ;;

+;; NOTE: This binding is used in libguile/modules.c.
+;;

 (define (set-current-module m)
   (set! the-module m)
   (if m
 (define (set-current-module m)
   (set! the-module m)
   (if m


@@ -1623,8 +1722,17 @@
 
 (define basic-load load)
 
 
 (define basic-load load)
 

-(define (load-module . args)
-  (save-module-excursion (lambda () (apply basic-load args))))
+(define (load-module filename)
+  (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))))))

 
 
 \f
 
 
 \f


@@ -1781,32 +1889,39 @@
 
 ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
 
 
 ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
 

+;; NOTE: This binding is used in libguile/modules.c.
+;;

 (define (resolve-module name . maybe-autoload)
   (let ((full-name (append '(app modules) name)))
     (let ((already (local-ref full-name)))
 (define (resolve-module name . maybe-autoload)
   (let ((full-name (append '(app modules) name)))
     (let ((already (local-ref full-name)))

-    (or already
-       (begin
-         (if (or (null? maybe-autoload) (car maybe-autoload))
-             (or (try-module-linked name)
-                 (try-module-autoload name)
-                 (try-module-dynamic-link name)))
-         (make-modules-in (current-module) full-name))))))
+      (or already
+         (begin
+           (if (or (null? maybe-autoload) (car maybe-autoload))
+               (or (try-module-linked name)
+                   (try-module-autoload name)
+                   (try-module-dynamic-link name)))
+           (make-modules-in (current-module) full-name))))))

            
 (define (beautify-user-module! module)
            
 (define (beautify-user-module! module)

-  (if (not (module-public-interface module))
-      (let ((interface (make-module 31)))
-       (set-module-name! interface (module-name module))
-       (set-module-kind! interface 'interface)
-       (set-module-public-interface! module interface)))
+  (let ((interface (module-public-interface module)))
+    (if (or (not interface)
+           (eq? interface module))
+       (let ((interface (make-module 31)))
+         (set-module-name! interface (module-name module))
+         (set-module-kind! interface 'interface)
+         (set-module-public-interface! module interface))))

   (if (and (not (memq the-scm-module (module-uses module)))
           (not (eq? module the-root-module)))
       (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
 
   (if (and (not (memq the-scm-module (module-uses module)))
           (not (eq? module the-root-module)))
       (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
 

+;; NOTE: This binding is used in libguile/modules.c.
+;;

 (define (make-modules-in module name)
   (if (null? name)
       module
       (cond
 (define (make-modules-in module name)
   (if (null? name)
       module
       (cond

-       ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
+       ((module-ref module (car name) #f)
+       => (lambda (m) (make-modules-in m (cdr name))))

        (else   (let ((m (make-module 31)))
                  (set-module-kind! m 'directory)
                  (set-module-name! m (car name))
        (else   (let ((m (make-module 31)))
                  (set-module-kind! m 'directory)
                  (set-module-name! m (car name))


@@ -1820,6 +1935,10 @@
 
 (define %autoloader-developer-mode #t)
 
 
 (define %autoloader-developer-mode #t)
 

+(define (internal-use-syntax transformer)
+  (set-module-transformer! (current-module) transformer)
+  (set! scm:eval-transformer transformer))
+

 (define (process-define-module args)
   (let*  ((module-id (car args))
          (module (resolve-module module-id #f))
 (define (process-define-module args)
   (let*  ((module-id (car args))
          (module (resolve-module module-id #f))


@@ -1831,28 +1950,43 @@
          (for-each (lambda (interface)
                      (module-use! module interface))
                    reversed-interfaces)
          (for-each (lambda (interface)
                      (module-use! module interface))
                    reversed-interfaces)

-         (case (cond ((keyword? (car kws))
-                      (keyword->symbol (car kws)))
-                     ((and (symbol? (car kws))
-                           (eq? (string-ref (car kws) 0) #\:))
-                      (string->symbol (substring (car kws) 1)))
-                     (else #f))
-           ((use-module)
-            (if (not (pair? (cdr kws)))
-                (error "unrecognized defmodule argument" kws))
-            (let* ((used-name (cadr kws))
-                   (used-module (resolve-module used-name)))
-              (if (not (module-ref used-module '%module-public-interface #f))
-                  (begin
-                    ((if %autoloader-developer-mode warn error)
-                     "no code for module" (module-name used-module))
-                    (beautify-user-module! used-module)))
-              (let ((interface (module-public-interface used-module)))
-                (if (not interface)
-                    (error "missing interface for use-module" used-module))
-                (loop (cddr kws) (cons interface reversed-interfaces)))))
-           (else       
-            (error "unrecognized defmodule argument" kws)))))
+         (let ((keyword (cond ((keyword? (car kws))
+                               (keyword->symbol (car kws)))
+                              ((and (symbol? (car kws))
+                                    (eq? (string-ref (car kws) 0) #\:))
+                               (string->symbol (substring (car kws) 1)))
+                              (else #f))))
+           (case keyword
+             ((use-module use-syntax)
+              (if (not (pair? (cdr kws)))
+                  (error "unrecognized defmodule argument" kws))
+              (let* ((used-name (cadr kws))
+                     (used-module (resolve-module used-name)))
+                (if (eq? used-module module)
+                    (begin
+                      (or (try-module-linked used-name)
+                          (try-module-dynamic-link used-name))
+                      (loop (cddr kws) reversed-interfaces))
+                    (begin
+                      (if (not (module-ref used-module
+                                           '%module-public-interface
+                                           #f))
+                          (begin
+                            ((if %autoloader-developer-mode warn error)
+                             "no code for module" (module-name used-module))
+                            (beautify-user-module! used-module)))
+                      (let ((interface (module-public-interface used-module)))
+                        (if (not interface)
+                            (error "missing interface for use-module"
+                                   used-module))
+                        (if (eq? keyword 'use-syntax)
+                            (internal-use-syntax
+                             (module-ref interface (car (last-pair used-name))
+                                         #f)))
+                        (loop (cddr kws)
+                              (cons interface reversed-interfaces)))))))
+             (else     
+              (error "unrecognized defmodule argument" kws))))))

     module))
 \f
 ;;; {Autoloading modules}
     module))
 \f
 ;;; {Autoloading modules}


@@ -1968,19 +2102,28 @@
     (c-clear-registered-modules)
     res))
 
     (c-clear-registered-modules)
     res))
 

-(define registered-modules (convert-c-registered-modules #f))
-    
+(define registered-modules '())
+
+(define (register-modules dynobj)
+  (set! registered-modules
+       (append! (convert-c-registered-modules dynobj)
+                registered-modules)))
+

 (define (init-dynamic-module modname)
 (define (init-dynamic-module modname)

+  ;; Register any linked modules which has been registered on the C level
+  (register-modules #f)

   (or-map (lambda (modinfo)
            (if (equal? (car modinfo) modname)
   (or-map (lambda (modinfo)
            (if (equal? (car modinfo) modname)

-               (let ((mod (resolve-module modname #f)))
-                 (save-module-excursion
-                  (lambda ()
-                    (set-current-module mod)
-                    (dynamic-call (cadr modinfo) (caddr modinfo))
-                    (set-module-public-interface! mod mod)))
+               (begin

                  (set! registered-modules (delq! modinfo registered-modules))
                  (set! registered-modules (delq! modinfo registered-modules))

-                 #t)
+                 (let ((mod (resolve-module modname #f)))
+                   (save-module-excursion
+                    (lambda ()
+                      (set-current-module mod)
+                      (set-module-public-interface! mod mod)
+                      (dynamic-call (cadr modinfo) (caddr modinfo))
+                      ))
+                   #t))

                #f))
          registered-modules))
 
                #f))
          registered-modules))
 


@@ -2008,36 +2151,65 @@
                                            #\_))
                                      (string->list mod-name)))
                   '_module))
                                            #\_))
                                      (string->list mod-name)))
                   '_module))

-  (let ((libname
+
+  ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+  ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+  ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+  ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+  (let ((subdir-and-libname

         (let loop ((dirs "")
                    (syms module-name))
         (let loop ((dirs "")
                    (syms module-name))

-          (cond
-           ((null? (cdr syms))
-            (string-append dirs "lib" (car syms) ".so"))
-           (else
-            (loop (string-append dirs (car syms) "/") (cdr syms))))))
+          (if (null? (cdr syms))
+              (cons dirs (string-append "lib" (car syms)))
+              (loop (string-append dirs (car syms) "/") (cdr syms)))))

        (init (make-init-name (apply string-append
                                     (map (lambda (s)
                                            (string-append "_" s))
                                          module-name)))))
        (init (make-init-name (apply string-append
                                     (map (lambda (s)
                                            (string-append "_" s))
                                          module-name)))))

-    ;; (pk 'libname libname 'init init)
-    (or-map
-     (lambda (dir)
-       (let ((full (in-vicinity dir libname)))
-        ;; (pk 'trying full)
-        (if (file-exists? full)
-            (begin
-              (link-dynamic-module full init)
-              #t)
-            #f)))
-     %load-path)))
+    (let ((subdir (car subdir-and-libname))
+         (libname (cdr subdir-and-libname)))
+
+      ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
+      ;; file exists, fetch the dlname from that file and attempt to link
+      ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
+      ;; to name any shared library, look for `subdir/libfoo.so' instead and
+      ;; link against that.
+      (let check-dirs ((dir-list %load-path))
+       (if (null? dir-list)
+           #f
+           (let* ((dir (in-vicinity (car dir-list) subdir))
+                  (sharlib-full
+                   (or (try-using-libtool-name dir libname)
+                       (try-using-sharlib-name dir libname))))
+             (if (and sharlib-full (file-exists? sharlib-full))
+                 (link-dynamic-module sharlib-full init)
+                 (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+  (let ((libtool-filename (in-vicinity libdir
+                                      (string-append libname ".la"))))
+    (and (file-exists? libtool-filename)
+        (with-input-from-file libtool-filename
+          (lambda ()
+            (let loop ((ln (read-line)))
+              (cond ((eof-object? ln) #f)
+                    ((and (> (string-length ln) 9)
+                          (string=? "dlname='" (substring ln 0 8))
+                          (string-index ln #\' 8))
+                     =>
+                     (lambda (end)
+                       (in-vicinity libdir (substring ln 8 end))))
+                    (else (loop (read-line))))))))))
+                             
+(define (try-using-sharlib-name libdir libname)
+  (in-vicinity libdir (string-append libname ".so")))

 
 (define (link-dynamic-module filename initname)
 
 (define (link-dynamic-module filename initname)

+  ;; Register any linked modules which has been registered on the C level
+  (register-modules #f)

   (let ((dynobj (dynamic-link filename)))
     (dynamic-call initname dynobj)
   (let ((dynobj (dynamic-link filename)))
     (dynamic-call initname dynobj)

-    (set! registered-modules 
-         (append! (convert-c-registered-modules dynobj)
-                  registered-modules))))
+    (register-modules dynobj)))

 
 (define (try-module-linked module-name)
   (init-dynamic-module module-name))
 
 (define (try-module-linked module-name)
   (init-dynamic-module module-name))


@@ -2153,7 +2325,11 @@
 
 ;;; {Run-time options}
 
 
 ;;; {Run-time options}
 

-((let* ((names '((debug-options-interface
+((let* ((names '((eval-options-interface
+                 (eval-options eval-enable eval-disable)
+                 (eval-set!))
+                
+                (debug-options-interface

                  (debug-options debug-enable debug-disable)
                  (debug-set!))
               
                  (debug-options debug-enable debug-disable)
                  (debug-set!))
               


@@ -2168,6 +2344,10 @@
                 (print-options-interface
                  (print-options print-enable print-disable)
                  (print-set!))
                 (print-options-interface
                  (print-options print-enable print-disable)
                  (print-set!))

+
+                (readline-options-interface
+                 (readline-options readline-enable readline-disable)
+                 (readline-set!))

                 ))
        (option-name car)
        (option-value cadr)
                 ))
        (option-name car)
        (option-value cadr)


@@ -2190,7 +2370,7 @@
        (make-options (lambda (interface)
                        `(lambda args
                           (cond ((null? args) (,interface))
        (make-options (lambda (interface)
                        `(lambda args
                           (cond ((null? args) (,interface))

-                                ((pair? (car args))
+                                ((list? (car args))

                                  (,interface (car args)) (,interface))
                                 (else (for-each ,print-option
                                                 (,interface #t)))))))
                                  (,interface (car args)) (,interface))
                                 (else (for-each ,print-option
                                                 (,interface #t)))))))


@@ -2269,6 +2449,7 @@
   (save-stack lazy-handler-dispatch)
   (apply throw key args))
 
   (save-stack lazy-handler-dispatch)
   (apply throw key args))
 

+(define enter-frame-handler default-lazy-handler)

 (define apply-frame-handler default-lazy-handler)
 (define exit-frame-handler default-lazy-handler)
 
 (define apply-frame-handler default-lazy-handler)
 (define exit-frame-handler default-lazy-handler)
 


@@ -2278,10 +2459,12 @@
      (apply apply-frame-handler key args))
     ((exit-frame)
      (apply exit-frame-handler key args))
      (apply apply-frame-handler key args))
     ((exit-frame)
      (apply exit-frame-handler key args))

+    ((enter-frame)
+     (apply enter-frame-handler key args))

     (else
      (apply default-lazy-handler key args))))
 
     (else
      (apply default-lazy-handler key args))))
 

-(define abort-hook '())
+(define abort-hook (make-hook))

 
 ;; these definitions are used if running a script.
 ;; otherwise redefined in error-catching-loop.
 
 ;; these definitions are used if running a script.
 ;; otherwise redefined in error-catching-loop.


@@ -2308,17 +2491,19 @@
                                    (dynamic-wind
                                     (lambda () (unmask-signals))
                                     (lambda ()
                                    (dynamic-wind
                                     (lambda () (unmask-signals))
                                     (lambda ()

-                                      (first)
+                                      (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)
+                                         ;; 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 () (mask-signals))))
 
                                  lazy-handler-dispatch))
                                     (lambda () (mask-signals))))
 
                                  lazy-handler-dispatch))


@@ -2338,7 +2523,7 @@
                         ;; (set! first #f) above
                         ;;
                         (lambda ()
                         ;; (set! first #f) above
                         ;;
                         (lambda ()

-                          (run-hooks abort-hook)
+                          (run-hook abort-hook)

                           (force-output)
                           (display "ABORT: "  (current-error-port))
                           (write args (current-error-port))
                           (force-output)
                           (display "ABORT: "  (current-error-port))
                           (write args (current-error-port))


@@ -2347,7 +2532,7 @@
                               (if (and (not has-shown-debugger-hint?)
                                        (not (memq 'backtrace
                                                   (debug-options-interface)))
                               (if (and (not has-shown-debugger-hint?)
                                        (not (memq 'backtrace
                                                   (debug-options-interface)))

-                                       (stack? the-last-stack))
+                                       (stack? (fluid-ref the-last-stack)))

                                   (begin
                                     (newline (current-error-port))
                                     (display
                                   (begin
                                     (newline (current-error-port))
                                     (display


@@ -2367,49 +2552,50 @@
        (if next (loop next) status)))
     (loop (lambda () #t))))
 
        (if next (loop next) status)))
     (loop (lambda () #t))))
 

-;;(define the-last-stack #f) Defined by scm_init_backtrace ()
+;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()

 (define stack-saved? #f)
 
 (define (save-stack . narrowing)
   (cond (stack-saved?)
        ((not (memq 'debug (debug-options-interface)))
 (define stack-saved? #f)
 
 (define (save-stack . narrowing)
   (cond (stack-saved?)
        ((not (memq 'debug (debug-options-interface)))

-        (set! the-last-stack #f)
+        (fluid-set! the-last-stack #f)

         (set! stack-saved? #t))
        (else
         (set! stack-saved? #t))
        (else

-        (set! the-last-stack
-              (case (stack-id #t)
-                ((repl-stack)
-                 (apply make-stack #t save-stack eval narrowing))
-                ((load-stack)
-                 (apply make-stack #t save-stack 0 narrowing))
-                ((tk-stack)
-                 (apply make-stack #t save-stack tk-stack-mark narrowing))
-                ((#t)
-                 (apply make-stack #t save-stack 0 1 narrowing))
-                (else (let ((id (stack-id #t)))
-                        (and (procedure? id)
-                             (apply make-stack #t save-stack id narrowing))))))
+        (fluid-set!
+         the-last-stack
+         (case (stack-id #t)
+           ((repl-stack)
+            (apply make-stack #t save-stack eval narrowing))
+           ((load-stack)
+            (apply make-stack #t save-stack 0 narrowing))
+           ((tk-stack)
+            (apply make-stack #t save-stack tk-stack-mark narrowing))
+           ((#t)
+            (apply make-stack #t save-stack 0 1 narrowing))
+           (else (let ((id (stack-id #t)))
+                   (and (procedure? id)
+                        (apply make-stack #t save-stack id narrowing))))))

         (set! stack-saved? #t))))
 
         (set! stack-saved? #t))))
 

-(define before-error-hook '())
-(define after-error-hook '())
-(define before-backtrace-hook '())
-(define after-backtrace-hook '())
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))

 
 (define has-shown-debugger-hint? #f)
 
 (define (handle-system-error key . args)
   (let ((cep (current-error-port)))
 
 (define has-shown-debugger-hint? #f)
 
 (define (handle-system-error key . args)
   (let ((cep (current-error-port)))

-    (cond ((not (stack? the-last-stack)))
+    (cond ((not (stack? (fluid-ref the-last-stack))))

          ((memq 'backtrace (debug-options-interface))
          ((memq 'backtrace (debug-options-interface))

-          (run-hooks before-backtrace-hook)
+          (run-hook before-backtrace-hook)

           (newline cep)
           (newline cep)

-          (display-backtrace the-last-stack cep)
+          (display-backtrace (fluid-ref the-last-stack) cep)

           (newline cep)
           (newline cep)

-          (run-hooks after-backtrace-hook)))
-    (run-hooks before-error-hook)
-    (apply display-error the-last-stack cep args)
-    (run-hooks after-error-hook)
+          (run-hook after-backtrace-hook)))
+    (run-hook before-error-hook)
+    (apply display-error (fluid-ref the-last-stack) cep args)
+    (run-hook after-error-hook)

     (force-output cep)
     (throw 'abort key)))
 
     (force-output cep)
     (throw 'abort key)))
 


@@ -2422,10 +2608,10 @@
 
 ;; Replaced by C code:
 ;;(define (backtrace)
 
 ;; Replaced by C code:
 ;;(define (backtrace)

-;;  (if the-last-stack
+;;  (if (fluid-ref the-last-stack)

 ;;      (begin
 ;;     (newline)
 ;;      (begin
 ;;     (newline)

-;;     (display-backtrace the-last-stack (current-output-port))
+;;     (display-backtrace (fluid-ref the-last-stack) (current-output-port))

 ;;     (newline)
 ;;     (if (and (not has-shown-backtrace-hint?)
 ;;              (not (memq 'backtrace (debug-options-interface))))
 ;;     (newline)
 ;;     (if (and (not has-shown-backtrace-hint?)
 ;;              (not (memq 'backtrace (debug-options-interface))))


@@ -2442,14 +2628,22 @@
 (define (gc-run-time)
   (cdr (assq 'gc-time-taken (gc-stats))))
 
 (define (gc-run-time)
   (cdr (assq 'gc-time-taken (gc-stats))))
 

-(define before-read-hook '())
-(define after-read-hook '())
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
+
+;;; The default repl-reader function.  We may override this if we've
+;;; the readline library.
+(define repl-reader
+  (lambda (prompt)
+    (display prompt)
+    (force-output)
+    (run-hook before-read-hook)
+    (read (current-input-port))))

 
 (define (scm-style-repl)
   (letrec (
           (start-gc-rt #f)
           (start-rt #f)
 
 (define (scm-style-repl)
   (letrec (
           (start-gc-rt #f)
           (start-rt #f)

-          (repl-report-reset (lambda () #f))

           (repl-report-start-timing (lambda ()
                                       (set! start-gc-rt (gc-run-time))
                                       (set! start-rt (get-internal-run-time))))
           (repl-report-start-timing (lambda ()
                                       (set! start-gc-rt (gc-run-time))
                                       (set! start-rt (get-internal-run-time))))


@@ -2475,17 +2669,15 @@
                 ((char=? ch #\newline)
                  (read-char))))))
           (-read (lambda ()
                 ((char=? ch #\newline)
                  (read-char))))))
           (-read (lambda ()

-                   (if scm-repl-prompt
-                       (begin
-                         (display (cond ((string? scm-repl-prompt)
-                                         scm-repl-prompt)
-                                        ((thunk? scm-repl-prompt)
-                                         (scm-repl-prompt))
-                                        (else "> ")))
-                         (force-output)
-                         (repl-report-reset)))
-                   (run-hooks before-read-hook)
-                   (let ((val (read (current-input-port))))
+                   (let ((val
+                          (let ((prompt (cond ((string? scm-repl-prompt)
+                                               scm-repl-prompt)
+                                              ((thunk? scm-repl-prompt)
+                                               (scm-repl-prompt))
+                                              (scm-repl-prompt "> ")
+                                              (else ""))))
+                            (repl-reader prompt))))
+

                      ;; As described in R4RS, the READ procedure updates the
                      ;; port to point to the first characetr past the end of
                      ;; the external representation of the object.  This
                      ;; As described in R4RS, the READ procedure updates the
                      ;; port to point to the first characetr past the end of
                      ;; the external representation of the object.  This


@@ -2497,7 +2689,7 @@
                      ;; trailing newline here, as well as any whitespace
                      ;; before it.
                      (consume-trailing-whitespace)
                      ;; trailing newline here, as well as any whitespace
                      ;; before it.
                      (consume-trailing-whitespace)

-                     (run-hooks after-read-hook)
+                     (run-hook after-read-hook)

                      (if (eof-object? val)
                          (begin
                            (repl-report-start-timing)
                      (if (eof-object? val)
                          (begin
                            (repl-report-start-timing)


@@ -2566,6 +2758,15 @@
            (lambda () (continue))
            (lambda v (cadr v)))))
 
            (lambda () (continue))
            (lambda v (cadr v)))))
 

+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;; (The definition relies on the current left-to-right
+;;;  order of evaluation of operands in applications.)
+
+(defmacro collect forms
+  (cons 'list forms))

 
 ;;; {with-fluids}
 
 
 ;;; {with-fluids}
 


@@ -2580,6 +2781,13 @@
   `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
                 (lambda () ,@body)))
 
   `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
                 (lambda () ,@body)))
 

+;;; Environments
+
+(define the-environment
+  (procedure->syntax
+   (lambda (x e)
+     e)))
+

 \f
 
 ;;; {Macros}
 \f
 
 ;;; {Macros}


@@ -2629,9 +2837,12 @@
 (defmacro use-modules modules
   `(process-use-modules ',modules))
 
 (defmacro use-modules modules
   `(process-use-modules ',modules))
 

-(define (use-syntax transformer)
-  (set-module-transformer! (current-module) transformer)
-  (set! scm:eval-transformer transformer))
+(defmacro use-syntax (spec)
+  (if (pair? spec)
+      `(begin
+        (process-use-modules ',(list spec))
+        (internal-use-syntax ,(car (last-pair spec))))
+      `(internal-use-syntax ,spec)))

 
 (define define-private define)
 
 
 (define define-private define)
 


@@ -2696,14 +2907,33 @@
                             (defmacro ,@ args))))))
 
 
                             (defmacro ,@ args))))))
 
 

+(defmacro export names
+  `(let* ((m (current-module))
+         (public-i (module-public-interface m)))
+     (for-each (lambda (name)
+                ;; Make sure there is a local variable:
+                (module-define! m name (module-ref m name #f))
+                ;; Make sure that local is exported:
+                (module-add! public-i name (module-variable m name)))
+              ',names)))
+
+(define export-syntax export)
+
+

 
 
 (define load load-module)
 
 
 (define load load-module)

-;(define (load . args)
-;  (start-stack 'load-stack (apply load-module args)))

 
 
 \f
 
 
 \f

+;;; {Load emacs interface support if emacs option is given.}
+
+(define (load-emacs-interface)
+  (if (memq 'debug-extensions *features*)
+      (debug-enable 'backtrace))
+  (define-module (guile-user) :use-module (ice-9 emacs)))
+
+\f

 ;;; {I/O functions for Tcl channels (disabled)}
 
 ;; (define in-ch (get-standard-channel TCL_STDIN))
 ;;; {I/O functions for Tcl channels (disabled)}
 
 ;; (define in-ch (get-standard-channel TCL_STDIN))


@@ -2742,6 +2972,15 @@
 ;; this is just (scm-style-repl) with a wrapper to install and remove 
 ;; signal handlers.
 (define (top-repl) 
 ;; this is just (scm-style-repl) with a wrapper to install and remove 
 ;; signal handlers.
 (define (top-repl) 

+
+  ;; Load emacs interface support if emacs option is given.
+  (if (and (module-defined? the-root-module 'use-emacs-interface)
+          use-emacs-interface)
+      (load-emacs-interface))
+
+  ;; Place the user in the guile-user module.
+  (define-module (guile-user))
+

   (let ((old-handlers #f)
        (signals `((,SIGINT . "User interrupt")
                   (,SIGFPE . "Arithmetic error")
   (let ((old-handlers #f)
        (signals `((,SIGINT . "User interrupt")
                   (,SIGFPE . "Arithmetic error")


@@ -2768,7 +3007,30 @@
 
      ;; the protected thunk.
      (lambda ()
 
      ;; the protected thunk.
      (lambda ()

-       (scm-style-repl))
+
+       ;; If we've got readline, use it to prompt the user.  This is a
+       ;; kludge, but we'll fix it soon.  At least we only get
+       ;; readline involved when we're actually running the repl.
+       (if (and (memq 'readline *features*)
+               (isatty? (current-input-port))
+               (not (and (module-defined? the-root-module
+                                          'use-emacs-interface)
+                         use-emacs-interface)))
+          (let ((read-hook (lambda () (run-hook before-read-hook))))
+            (set-current-input-port (readline-port))
+            (set! repl-reader
+                  (lambda (prompt)
+                    (dynamic-wind
+                     (lambda ()
+                       (set-readline-prompt! prompt)
+                       (set-readline-read-hook! read-hook))
+                     (lambda () (read))
+                     (lambda ()
+                       (set-readline-prompt! "")
+                       (set-readline-read-hook! #f)))))))
+       (let ((status (scm-style-repl)))
+        (run-hook exit-hook)
+        status))

 
      ;; call at exit.
      (lambda ()
 
      ;; call at exit.
      (lambda ()


@@ -2786,52 +3048,56 @@
   `(catch #t (lambda () ,expr)
          (lambda args #f)))
 
   `(catch #t (lambda () ,expr)
          (lambda args #f)))
 

-;;; {Load debug extension code if debug extensions present.}
-;;;
-;;; *fixme* This is a temporary solution.
+;;; This hook is run at the very end of an interactive session.

 ;;;
 ;;;

+(define exit-hook (make-hook))

 
 

-(if (memq 'debug-extensions *features*)
-    (define-module (guile) :use-module (ice-9 debug)))
+;;; Load readline code into root module if readline primitives are available.
+;;;
+;;; Ideally, we wouldn't do this until we were sure we were actually
+;;; going to enter the repl, but autoloading individual functions is
+;;; clumsy at the moment.
+(if (and (memq 'readline *features*)
+        (isatty? (current-input-port)))
+    (begin
+      (define-module (guile) :use-module (ice-9 readline))
+      (define-module (guile-user) :use-module (ice-9 readline))))

 
 \f
 
 \f

-;;; {Load session support if present.}
+;;; {Load debug extension code into user module if debug extensions present.}

 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 
 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 

-(if (%search-load-path "ice-9/session.scm")
-    (define-module (guile) :use-module (ice-9 session)))
+(if (memq 'debug-extensions *features*)
+    (define-module (guile-user) :use-module (ice-9 debug)))

 
 \f
 
 \f

-;;; {Load thread code if threads are present.}
+;;; {Load session support into user module if present.}

 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 
 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 

-(if (memq 'threads *features*)
-    (define-module (guile) :use-module (ice-9 threads)))
+(if (%search-load-path "ice-9/session.scm")
+    (define-module (guile-user) :use-module (ice-9 session)))

 
 

-\f
-;;; {Load emacs interface support if emacs option is given.}
+;;; {Load thread code into user module if threads are present.}

 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 
 ;;;
 ;;; *fixme* This is a temporary solution.
 ;;;
 

-(if (and (module-defined? the-root-module 'use-emacs-interface)
-        use-emacs-interface)
-    (begin
-      (if (memq 'debug-extensions *features*)
-         (debug-enable 'backtrace))
-      (define-module (guile) :use-module (ice-9 emacs))))
+(if (memq 'threads *features*)
+    (define-module (guile-user) :use-module (ice-9 threads)))

 
 \f
 ;;; {Load regexp code if regexp primitives are available.}
 
 (if (memq 'regex *features*)
 
 \f
 ;;; {Load regexp code if regexp primitives are available.}
 
 (if (memq 'regex *features*)

-    (define-module (guile) :use-module (ice-9 regex)))
+    (define-module (guile-user) :use-module (ice-9 regex)))

 
 \f
 
 \f

+(define-module (guile))
+

 ;;; {Check that the interpreter and scheme code match up.}
 
 (let ((show-line
 ;;; {Check that the interpreter and scheme code match up.}
 
 (let ((show-line


@@ -2854,8 +3120,5 @@
        (show-line "libguile: configured on " (libguile-config-stamp))
        (show-line "ice-9:    configured on " (ice-9-config-stamp)))))
     
        (show-line "libguile: configured on " (libguile-config-stamp))
        (show-line "ice-9:    configured on " (ice-9-config-stamp)))))
     

-\f
-
-(define-module (guile))
-

 (append! %load-path (cons "." ()))
 (append! %load-path (cons "." ()))

+