mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-03 08:10:31 +02:00
Code Activity

rewrite use-modules and use-syntax using syntax-case

Browse source 
* module/ice-9/boot-9.scm (use-modules): Rewrite as a syntax-case macro.
  (use-syntax): Likewise.
  (compile-interface-spec): Remove unused function
This commit is contained in:
Andy Wingo 2010-05-03 16:31:32 +02:00
parent 074e036ee2
commit 4e3328ce69
1 changed files with 50 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -3256,30 +3256,6 @@ module '(ice-9 q) '(make-q q-length))}."
(if (memq 'prefix (read-options))
(error "boot-9 must be compiled with #:kw, not :kw")))
(define (compile-interface-spec spec)
(define (make-keyarg sym key quote?)
(cond ((or (memq sym spec)
(memq key spec))
=> (lambda (rest)
(if quote?
(list key (list 'quote (cadr rest)))
(list key (cadr rest)))))
(else
'())))
(define (map-apply func list)
(map (lambda (args) (apply func args)) list))
(define keys
;; sym key quote?
'((:select #:select #t)
(:hide #:hide #t)
(:prefix #:prefix #t)
(:renamer #:renamer #f)
(:version #:version #t)))
(if (not (pair? (car spec)))
`(',spec)
`(',(car spec)
,@(apply append (map-apply make-keyarg keys)))))
(define (keyword-like-symbol->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
@ -3371,22 +3347,57 @@ module '(ice-9 q) '(make-q q-length))}."
(lambda ()
(module-use-interfaces! (current-module) interfaces)))))
(defmacro use-modules modules
`(eval-when
(eval load compile)
(process-use-modules
(list ,@(map (lambda (m)
`(list ,@(compile-interface-spec m)))
modules)))
*unspecified*))
(define-syntax use-modules
(lambda (x)
(define (keyword-like? stx)
(let ((dat (syntax->datum stx)))
(and (symbol? dat)
(eqv? (string-ref (symbol->string dat) 0) #\:))))
(define (->keyword sym)
(symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
(defmacro use-syntax (spec)
`(eval-when
(eval load compile)
(define (quotify-iface args)
(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))
((#:renamer renamer . in)
(loop #'in (cons* #'renamer #:renamer out)))
((kw val . in)
(loop #'in (cons* #''val #'kw out))))))
(define (quotify specs)
(let lp ((in specs) (out '()))
(syntax-case in ()
(() (reverse out))
(((name name* ...) . in)
(and-map symbol? (syntax->datum #'(name name* ...)))
(lp #'in (cons #''((name name* ...)) out)))
((((name name* ...) arg ...) . in)
(and-map symbol? (syntax->datum #'(name name* ...)))
(with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
(lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
out)))))))
(syntax-case x ()
((_ spec ...)
(with-syntax (((quoted-args ...) (quotify #'(spec ...))))
#'(eval-when (eval load compile)
(process-use-modules (list quoted-args ...))
*unspecified*))))))
(define-syntax use-syntax
(syntax-rules ()
((_ spec ...)
(begin
(eval-when (eval load compile)
(issue-deprecation-warning
"`use-syntax' is deprecated. Please contact guile-devel for more info.")
(process-use-modules (list (list ,@(compile-interface-spec spec))))
*unspecified*))
"`use-syntax' is deprecated. Please contact guile-devel for more info."))
(use-modules spec ...)))))
(define-syntax define-private
(syntax-rules ()