X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/7398c2c2b576d7fe7e9994eba1b3a36fdf6e6932..49e5d550cb011819cc3d878d82a99a005002d0db:/ice-9/boot-9.scm

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index f7c59c2a8..846960702 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -519,7 +519,7 @@
 
 
 
-;;; {and-map, or-map, and map-in-order}
+;;; {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...) ...)
@@ -552,36 +552,47 @@
 	(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)))))
-
 
 ;;; {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)
-  (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!
-  (procedure->macro
+  (procedure->memoizing-macro
     (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->macro
+  (procedure->memoizing-macro
     (lambda (exp env)
-      `(let ((thunk ,(caddr exp)))
-	 (if (memq thunk ,(cadr exp))
-	     (set! ,(cadr exp)
-		   (delq! thunk ,(cadr exp))))))))
+      (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))))))))))
 
 
 ;;; {Files}
@@ -1350,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))
+
+;; NOTE: This binding is used in libguile/modules.c.
 (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))
@@ -1660,7 +1674,9 @@
 
 
 ;; the-module
-;; 
+;;
+;; NOTE: This binding is used in libguile/modules.c.
+;;
 (define the-module #f)
 
 ;; scm:eval-transformer
@@ -1671,6 +1687,8 @@
 ;;
 ;; 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
@@ -1871,32 +1889,39 @@
 
 ;; (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)))
-    (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)
-  (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)))))
 
+;; NOTE: This binding is used in libguile/modules.c.
+;;
 (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))
@@ -1937,19 +1962,29 @@
 		   (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))
+		 (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 %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)))))
+		       (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))
@@ -2067,19 +2102,28 @@
     (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)
+  ;; Register any linked modules which has been registered on the C level
+  (register-modules #f)
   (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))
-		  #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))
 
@@ -2149,7 +2193,7 @@
 	   (lambda ()
 	     (let loop ((ln (read-line)))
 	       (cond ((eof-object? ln) #f)
-		     ((and (>= (string-length ln) 8)
+		     ((and (> (string-length ln) 9)
 			   (string=? "dlname='" (substring ln 0 8))
 			   (string-index ln #\' 8))
 		      =>
@@ -2161,11 +2205,11 @@
   (in-vicinity libdir (string-append libname ".so")))
 
 (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)
-    (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))
@@ -2420,7 +2464,7 @@
     (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.
@@ -2479,7 +2523,7 @@
 			 ;; (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))
@@ -2533,10 +2577,10 @@
 			 (apply make-stack #t save-stack id narrowing))))))
 	 (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)
 
@@ -2544,14 +2588,14 @@
   (let ((cep (current-error-port)))
     (cond ((not (stack? (fluid-ref the-last-stack))))
 	  ((memq 'backtrace (debug-options-interface))
-	   (run-hooks before-backtrace-hook)
+	   (run-hook before-backtrace-hook)
 	   (newline cep)
 	   (display-backtrace (fluid-ref the-last-stack) cep)
 	   (newline cep)
-	   (run-hooks after-backtrace-hook)))
-    (run-hooks before-error-hook)
+	   (run-hook after-backtrace-hook)))
+    (run-hook before-error-hook)
     (apply display-error (fluid-ref the-last-stack) cep args)
-    (run-hooks after-error-hook)
+    (run-hook after-error-hook)
     (force-output cep)
     (throw 'abort key)))
 
@@ -2584,8 +2628,8 @@
 (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.
@@ -2593,7 +2637,7 @@
   (lambda (prompt)
     (display prompt)
     (force-output)
-    (run-hooks before-read-hook)
+    (run-hook before-read-hook)
     (read (current-input-port))))
 
 (define (scm-style-repl)
@@ -2645,7 +2689,7 @@
 		      ;; 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)
@@ -2737,6 +2781,13 @@
   `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
 		 (lambda () ,@body)))
 
+;;; Environments
+
+(define the-environment
+  (procedure->syntax
+   (lambda (x e)
+     e)))
+
 
 
 ;;; {Macros}
@@ -2965,7 +3016,7 @@
 		(not (and (module-defined? the-root-module
 					   'use-emacs-interface)
 			  use-emacs-interface)))
-	   (let ((read-hook (lambda () (run-hooks before-read-hook))))
+	   (let ((read-hook (lambda () (run-hook before-read-hook))))
 	     (set-current-input-port (readline-port))
 	     (set! repl-reader
 		   (lambda (prompt)
@@ -2978,7 +3029,7 @@
 			(set-readline-prompt! "")
 			(set-readline-read-hook! #f)))))))
        (let ((status (scm-style-repl)))
-	 (run-hooks exit-hook)
+	 (run-hook exit-hook)
 	 status))
 
      ;; call at exit.
@@ -2999,7 +3050,7 @@
 
 ;;; This hook is run at the very end of an interactive session.
 ;;;
-(define exit-hook '())
+(define exit-hook (make-hook))
 
 ;;; Load readline code into root module if readline primitives are available.
 ;;;