mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

define-module compiles to define-module*

Browse source 
* module/ice-9/boot-9.scm (define-module): Compile down to a call to
  define-module*, not process-define-module.
This commit is contained in:
Andy Wingo 2010-11-19 14:43:31 +01:00
parent 57ced5b97a
commit cd8c35193c
1 changed files with 67 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

105
module/ice-9/boot-9.scm
View file

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