guile/guile-core/ice-9 boot-9.scm

[Thien-Thi Nguyen]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Thien-Thi Nguyen <address@hidden>       01/05/10 15:00:22

Modified files:
        guile-core/ice-9: boot-9.scm 

Log message:
        (resolve-module): Abstraction maintenance: Use
        `module-public-interface'.
        (resolve-module): Extend to handle selection and renaming in spec.
        Arg is now `spec' which can be a simple module name (list of symbols)
        or a interface spec.
        (symbol-prefix-proc): New proc.
        (process-define-module): Use "define-module" in error messages
        instead of "defmodule".  Factor error into internal proc.
        Rewrite `use-module' and `use-syntax' handlers.
        Replace some single-arm `if-not' constructs w/ `or'.
        (process-use-modules): Arg is now `module-interface-specs',
        which is passed through to `resolve-interface' as before; nfc.
        (named-module-use!, top-repl): Abstraction maintenance: Use `provided?'.

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/boot-9.scm.diff?cvsroot=OldCVS&tr1=1.240&tr2=1.241&r1=text&r2=text

Patches:
Index: guile/guile-core/ice-9/boot-9.scm
diff -u guile/guile-core/ice-9/boot-9.scm:1.240 
guile/guile-core/ice-9/boot-9.scm:1.241
--- guile/guile-core/ice-9/boot-9.scm:1.240     Sat May  5 06:41:59 2001
+++ guile/guile-core/ice-9/boot-9.scm   Thu May 10 15:00:22 2001
@@ -1560,7 +1560,7 @@
       (if already
          ;; The module already exists...
          (if (and (or (null? maybe-autoload) (car maybe-autoload))
-                  (not (module-ref already '%module-public-interface #f)))
+                  (not (module-public-interface already)))
              ;; ...but we are told to load and it doesn't contain source, so
              (begin
                (try-load-module name)
@@ -1584,7 +1584,8 @@
          (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)))))
+      (set-module-uses! module (append (module-uses module)
+                                       (list the-scm-module)))))
 
 (define (purify-module! module)
   "Removes bindings in MODULE which are inherited from the (guile) module."
@@ -1609,17 +1610,70 @@
                  (module-define! module (car name) m)
                  (make-modules-in m (cdr name)))))))
 
-(define (resolve-interface name)
-  (let ((module (resolve-module name)))
-    (and module (module-public-interface module))))
-
-
-(define %autoloader-developer-mode #t)
+;; Return a module interface made from SPEC.
+;; SPEC can be a list of symbols, in which case it names a module
+;; whose public interface is found and returned.
+;;
+;; SPEC can also be of the form:
+;;  (MODULE-NAME [:select SELECTION] [:rename RENAMER])
+;; in which case a partial interface is newly created and returned.
+;; MODULE-NAME is a list of symbols, as above; SELECTION is a list of
+;; selection-specs to be imported; and RENAMER is a procedure that takes a
+;; symbol and returns its new name.  A selection-spec is either a symbol or a
+;; pair of symbols (ORIG . SEEN), where ORIG is the name in the used module
+;; and SEEN is the name in the using module.  Note that SEEN is also passed
+;; through RENAMER.
+;;
+;; The `:select' and `:rename' clauses are optional.  If both are omitted, the
+;; returned interface has no bindings.  If the `:select' clause is omitted,
+;; RENAMER operates on the used module's public interface.
+;;
+;; Signal error if module name is not resolvable.
+;;
+(define (resolve-interface spec)
+  (let* ((simple? (not (pair? (car spec))))
+         (name (if simple? spec (car spec)))
+         (module (resolve-module name)))
+    (if (not module)
+        (error "no code for module" name)
+        (let ((public-i (module-public-interface module)))
+          (cond ((not public-i)
+                 (beautify-user-module! module)
+                 (set! public-i (module-public-interface module))))
+          (if simple?
+              public-i
+              (let ((selection (cond ((memq ':select spec) => cadr)
+                                     (else (module-map (lambda (sym var) sym)
+                                                       public-i))))
+                    (rename (cond ((memq ':rename spec)
+                                   => (lambda (x)
+                                        (eval (cadr x) (current-module))))
+                                  (else identity)))
+                    (partial-i (make-module 31)))
+                (set-module-kind! partial-i 'interface)
+                (for-each (lambda (sel-spec)
+                            (let* ((direct? (symbol? sel-spec))
+                                   (orig (if direct?
+                                             sel-spec
+                                             (car sel-spec)))
+                                   (seen (if direct?
+                                             sel-spec
+                                             (cdr sel-spec))))
+                              (module-add! partial-i (rename seen)
+                                           (module-variable module orig))))
+                          selection)
+                partial-i))))))
+
+(define (symbol-prefix-proc prefix)
+  (lambda (symbol)
+    (symbol-append prefix symbol)))
 
 (define (process-define-module args)
   (let*  ((module-id (car args))
          (module (resolve-module module-id #f))
-         (kws (cdr args)))
+         (kws (cdr args))
+          (unrecognized (lambda ()
+                          (error "unrecognized define-module argument" kws))))
     (beautify-user-module! module)
     (let loop ((kws kws)
               (reversed-interfaces '())
@@ -1638,32 +1692,24 @@
                                         (string->symbol (substring s 1))))))))
            (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 (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)
-                      (set-module-transformer!
-                       module
-                       (module-ref interface (car (last-pair used-name))
-                                   #f)))
-                  (loop (cddr kws)
-                        (cons interface reversed-interfaces)
-                        exports))))
+              (or (pair? (cdr kws))
+                  (unrecognized))
+               (let* ((spec (cadr kws))
+                      (interface (resolve-interface spec)))
+                 (and (eq? keyword 'use-syntax)
+                      (or (symbol? (car spec))
+                          (error "invalid module name for use-syntax"
+                                 spec))
+                      (set-module-transformer!
+                       module
+                       (module-ref interface (car (last-pair module-name))
+                                   #f)))
+                 (loop (cddr kws)
+                       (cons interface reversed-interfaces)
+                       exports)))
              ((autoload)
-              (if (not (and (pair? (cdr kws)) (pair? (cddr kws))))
-                  (error "unrecognized defmodule argument" kws))
+              (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+                   (unrecognized))
               (loop (cdddr kws)
                     (cons (make-autoload-interface module
                                                    (cadr kws)
@@ -1677,13 +1723,13 @@
               (purify-module! module)
               (loop (cdr kws) reversed-interfaces exports))
              ((export)
-              (if (not (pair? (cdr kws)))
-                  (error "unrecognized defmodule argument" kws))
+              (or (pair? (cdr kws))
+                   (unrecognized))
               (loop (cddr kws)
                     reversed-interfaces
                     (append (cadr kws) exports)))
              (else
-              (error "unrecognized defmodule argument" kws))))))
+               (unrecognized))))))
     (set-current-module module)
     module))
 
@@ -1784,7 +1830,7 @@
       (issue-deprecation-warning
        "Autoloading of compiled code modules is deprecated."
        "Write a Scheme file instead that uses `dynamic-link' directly.")))
-   
+
 (define (init-dynamic-module modname)
   ;; Register any linked modules which have been registered on the C level
   (register-modules #f)
@@ -2557,13 +2603,13 @@
 
 ;; the guts of the use-modules macro.  add the interfaces of the named
 ;; modules to the use-list of the current module, in order
-(define (process-use-modules module-names)
-  (for-each (lambda (module-name)
-             (let ((mod-iface (resolve-interface module-name)))
+(define (process-use-modules module-interface-specs)
+  (for-each (lambda (mif-spec)
+             (let ((mod-iface (resolve-interface mif-spec)))
                (or mod-iface
-                   (error "no such module" module-name))
+                   (error "no such module" mif-spec))
                (module-use! (current-module) mod-iface)))
-           (reverse module-names)))
+            module-interface-specs))
 
 (defmacro use-modules modules
   `(eval-case
@@ -2649,8 +2695,8 @@
   (module-use! (resolve-module user) (resolve-module usee)))
 
 (define (load-emacs-interface)
-  (if (memq 'debug-extensions *features*)
-      (debug-enable 'backtrace))
+  (and (provided? 'debug-extensions)
+       (debug-enable 'backtrace))
   (named-module-use! '(guile-user) '(ice-9 emacs)))
 
 
@@ -2675,10 +2721,10 @@
      :use-module (ice-9 session)
      :use-module (ice-9 debug)
      :autoload (ice-9 debugger) (debug)))  ;load debugger on demand
-  (if (memq 'threads *features*)
-      (named-module-use! '(guile-user) '(ice-9 threads)))
-  (if (memq 'regex *features*)
-      (named-module-use! '(guile-user) '(ice-9 regex)))
+  (and (provided? 'threads)
+       (named-module-use! '(guile-user) '(ice-9 threads)))
+  (and (provided? 'regex)
+       (named-module-use! '(guile-user) '(ice-9 regex)))
 
   (let ((old-handlers #f)
        (signals (if (provided? 'posix)