diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 87afc1566..d488aada3 100644 --- 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)))))))