define-module compiles to define-module*

[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 87afc15..d488aad 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2857,9 +2857,6 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (keyword-like-symbol->keyword sym)
   (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
 
-;; FIXME: we really need to clean up the guts of the module system.
-;; We can compile to something better than process-define-module.
-;;
 (define-syntax define-module
   (lambda (x)
     (define (keyword-like? stx)
@@ -2869,7 +2866,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (->keyword sym)
       (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
     
-    (define (quotify-iface args)
+    (define (parse-iface args)
       (let loop ((in args) (out '()))
         (syntax-case in ()
           (() (reverse! out))
@@ -2879,59 +2876,83 @@ module '(ice-9 q) '(make-q q-length))}."
           ((kw . in) (not (keyword? (syntax->datum #'kw)))
            (syntax-violation 'define-module "expected keyword arg" x #'kw))
           ((#:renamer renamer . in)
-           (loop #'in (cons* #'renamer #:renamer out)))
+           (loop #'in (cons* #',renamer #:renamer out)))
           ((kw val . in)
-           (loop #'in (cons* #''val #'kw out))))))
+           (loop #'in (cons* #'val #'kw out))))))
 
-    (define (quotify args)
+    (define (parse args imp exp rex rep aut)
       ;; Just quote everything except #:use-module and #:use-syntax.  We
       ;; need to know about all arguments regardless since we want to turn
       ;; symbols that look like keywords into real keywords, and the
       ;; keyword args in a define-module form are not regular
       ;; (i.e. no-backtrace doesn't take a value).
-      (let loop ((in args) (out '()))
-        (syntax-case in ()
-          (() (reverse! out))
-          ;; The user wanted #:foo, but wrote :foo. Fix it.
-          ((sym . in) (keyword-like? #'sym)
-           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
-          ((kw . in) (not (keyword? (syntax->datum #'kw)))
-           (syntax-violation 'define-module "expected keyword arg" x #'kw))
-          ((#:no-backtrace . in)
-           (loop #'in (cons #:no-backtrace out)))
-          ((#:pure . in)
-           (loop #'in (cons #:pure out)))
-          ((kw)
-           (syntax-violation 'define-module "keyword arg without value" x #'kw))
-          ((use-module (name name* ...) . in)
-           (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
-                (and-map symbol? (syntax->datum #'(name name* ...))))
-           (loop #'in
-                 (cons* #''((name name* ...))
-                        #'use-module
-                        out)))
-          ((use-module ((name name* ...) arg ...) . in)
-           (and (memq (syntax->datum #'use-module) '(#:use-module #:use-syntax))
-                (and-map symbol? (syntax->datum #'(name name* ...))))
-           (loop #'in
-                 (cons* #`(list '(name name* ...) #,@(quotify-iface #'(arg ...)))
-                        #'use-module
-                        out)))
-          ((#:autoload name bindings . in)
-           (loop #'in (cons* #''bindings #''name #:autoload out)))
-          ((kw val . in)
-           (loop #'in (cons* #''val #'kw out))))))
+      (syntax-case args ()
+        (()
+         (let ((imp (if (null? imp) '() #`(#:imports `#,imp)))
+               (exp (if (null? exp) '() #`(#:exports '#,exp)))
+               (rex (if (null? rex) '() #`(#:re-exports '#,rex)))
+               (rep (if (null? rep) '() #`(#:replacements '#,rep)))
+               (aut (if (null? aut) '() #`(#:autoloads '#,aut))))
+           #`(#,@imp #,@exp #,@rex #,@rep #,@aut)))
+        ;; The user wanted #:foo, but wrote :foo. Fix it.
+        ((sym . args) (keyword-like? #'sym)
+         (parse #`(#,(->keyword (syntax->datum #'sym)) . args)
+                  imp exp rex rep aut))
+        ((kw . args) (not (keyword? (syntax->datum #'kw)))
+         (syntax-violation 'define-module "expected keyword arg" x #'kw))
+        ((#:no-backtrace . args)
+         ;; Ignore this one.
+         (parse #'args imp exp rex rep aut))
+        ((#:pure . args)
+         #`(#:pure #t . #,(parse #'args imp exp rex rep aut)))
+        ((kw)
+         (syntax-violation 'define-module "keyword arg without value" x #'kw))
+        ((#:version (v ...) . args)
+         #`(#:version '(v ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#:duplicates (d ...) . args)
+         #`(#:duplicates '(d ...) . #,(parse #'args imp exp rex rep aut)))
+        ((#:filename f . args)
+         #`(#: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))
+        ((#: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)))
+        ((#:use-module ((name name* ...) arg ...) . args)
+         (and (and-map symbol? (syntax->datum #'(name name* ...))))
+         (parse #'args
+                (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+                exp rex rep aut))
+        ((#:export (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#:export-syntax (ex ...) . args)
+         (parse #'args imp #`(#,@exp ex ...) rex rep aut))
+        ((#:re-export (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#:re-export-syntax (re ...) . args)
+         (parse #'args imp exp #`(#,@rex re ...) rep aut))
+        ((#:replace (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#:replace-syntax (r ...) . args)
+         (parse #'args imp exp rex #`(#,@rep r ...) aut))
+        ((#:autoload name bindings . args)
+         (parse #'args imp exp rex rep #`(#,@aut name bindings)))
+        ((kw val . args)
+         (syntax-violation 'define-module "unknown keyword or bad argument"
+                           #'kw #'val))))
     
     (syntax-case x ()
       ((_ (name name* ...) arg ...)
-       (with-syntax (((quoted-arg ...) (quotify #'(arg ...))))
+       (and-map symbol? (syntax->datum #'(name name* ...)))
+       (with-syntax (((quoted-arg ...)
+                      (parse #'(arg ...) '() '() '() '() '()))
+                     (filename (assq-ref (or (syntax-source x) '())
+                                         'filename)))
          #'(eval-when (eval load compile expand)
-             (let ((m (process-define-module
-                       (list '(name name* ...)
-                             #:filename (assq-ref
-                                         (or (current-source-location) '())
-                                         'filename)
-                             quoted-arg ...))))
+             (let ((m (define-module* '(name name* ...)
+                        #:filename filename quoted-arg ...)))
                (set-current-module m)
                m)))))))