mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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

113
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)
(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)))))))