~ chicken-core (chicken-5) 01f77922a1cb2a81e07c82c6b3a5744cc085fcc2
commit 01f77922a1cb2a81e07c82c6b3a5744cc085fcc2
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Mar 19 17:50:38 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Mar 19 17:50:38 2011 +0100
functors
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 2db03701..8b1034fe 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1117,20 +1117,52 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'define-interface x '(_ symbol _))
- (let ((name (##sys#strip-syntax (cadr x))))
+ (let ((name (##sys#strip-syntax (cadr x)))
+ (%quote (r 'quote)))
`(,(r 'begin-for-syntax)
(##sys#register-interface
- ',name
- ',(let ((exps (##sys#strip-syntax (caddr x))))
- (cond ((eq? '* exps) '*)
- ((symbol? exps) `(#:interface ,exps))
- ((list? exps) (##sys#validate-exports exps 'define-interface))
- (else (##sys#syntax-error-hook
- 'define-interface "invalid exports" (caddr x)))))))))))
+ (,%quote ,name)
+ (,%quote ,(let ((exps (##sys#strip-syntax (caddr x))))
+ (cond ((eq? '* exps) '*)
+ ((symbol? exps) `(#:interface ,exps))
+ ((list? exps) (##sys#validate-exports exps 'define-interface))
+ (else (##sys#syntax-error-hook
+ 'define-interface "invalid exports" (caddr x))))))))))))
+;;; functor definition
+
+(##sys#extend-macro-environment
+ 'functor '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'functor x '(_ (symbol . #((symbol _) 0)) . _))
+ (let* ((x (##sys#strip-syntax x))
+ (head (cadr x))
+ (name (car head))
+ (body (cddr x))
+ (%quote (r 'quote))
+ (registration
+ `(##sys#register-functor
+ ',name
+ ',(map (lambda (arg)
+ (let ((argname (car arg))
+ (exps (##sys#validate-exports (cadr arg) 'functor)))
+ (cons argname exps)))
+ (cdr head))
+ ',body)))
+ `(##core#module
+ ,name
+ #t
+ (import scheme chicken)
+ (begin-for-syntax ,registration))))))
+
+
+;; capture current macro env
+
(##sys#macro-subset me0 ##sys#default-macro-environment)))
+
;; register features
(eval-when (compile load eval)
diff --git a/compiler.scm b/compiler.scm
index 5ddc5608..33e317d2 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -602,10 +602,11 @@
(let loop ([ids (##sys#strip-syntax (cadr x))])
(if (null? ids)
'(##core#undefined)
- (let ([id (car ids)])
+ (let ((id (##sys#resolve-module-name (car ids) #f)))
(let-values ([(exp f)
(##sys#do-the-right-thing
- id #t imp?)])
+ (##sys#resolve-module-name id #f)
+ #t imp?)])
(unless (or f
(and (symbol? id)
(or (feature? id)
@@ -808,13 +809,13 @@
e se dest ldest h))
((##core#let-module-alias)
- (fluid-let ((##sys#module-alias-environment
- (cons
- (##sys#strip-syntax
- (map (lambda (b) (cons (car b) (cadr b)))
- (cadr x)))
- ##sys#module-alias-environment)))
- (walk `(##core#begin ,@(cddr x)) e se dest ldest h)))
+ (##sys#with-module-aliases
+ (map (lambda (b)
+ (##sys#check-syntax 'functor b '(symbol symbol))
+ (##sys#strip-syntax b))
+ (cadr x))
+ (lambda ()
+ (walk `(##core#begin ,@(cddr x)) e se dest ldest h))))
((##core#module)
(let* ((x (##sys#strip-syntax x))
@@ -857,7 +858,7 @@
(lambda (il)
(when enable-module-registration
(emit-import-lib name il))
- (values
+ (values
(reverse xs)
'((##core#undefined)))))
((not enable-module-registration)
@@ -869,7 +870,8 @@
(reverse xs)
(if standalone-executable
'()
- (##sys#compiled-module-registration (##sys#current-module)))))))
+ (##sys#compiled-module-registration
+ (##sys#current-module)))))))
(else
(loop
(cdr body)
@@ -1162,7 +1164,9 @@
(list
var
(foreign-type-convert-result
- (finish-foreign-result (final-foreign-type type) var)
+ (finish-foreign-result
+ (final-foreign-type type)
+ var)
type) )
(loop (cdr vars) (cdr types)) ) ) ) )
,(foreign-type-convert-argument
diff --git a/eval.scm b/eval.scm
index d482c12e..f93fe3c1 100644
--- a/eval.scm
+++ b/eval.scm
@@ -615,13 +615,13 @@
e #f tf cntr se))
((##core#let-module-alias)
- (fluid-let ((##sys#module-alias-environment
- (cons
- (##sys#strip-syntax
- (map (lambda (b) (cons (car b) (cadr b)))
- (cadr x)))
- ##sys#module-alias-environment)))
- (walk `(##core#begin ,@(cddr x)) e #f tf cntr se)))
+ (##sys#with-module-aliases
+ (map (lambda (b)
+ (##sys#check-syntax 'functor b '(symbol symbol))
+ (##sys#strip-syntax b))
+ (cadr x))
+ (lambda ()
+ (compile `(##core#begin ,@(cddr x)) e #f tf cntr se))))
((##core#module)
(let* ((x (##sys#strip-syntax x))
@@ -692,7 +692,8 @@
'(##core#undefined)
(let-values ([(exp _)
(##sys#do-the-right-thing
- (car ids) #f imp?)])
+ (##sys#resolve-module-name (car ids) #f)
+ #f imp?)])
`(##core#begin ,exp ,(loop (cdr ids))) ) ) )
e #f tf cntr se) ) ]
diff --git a/expand.scm b/expand.scm
index e6fc4769..69a38a03 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1312,21 +1312,38 @@
'()
(##sys#er-transformer
(lambda (x r c)
- ;;XXX module alias + functor application
- (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
- ;;XXX use module name in "loc" argument?
- (let ((exports (##sys#validate-exports (##sys#strip-syntax (caddr x)) 'module)))
- `(##core#module
- ,(cadr x)
- ,(if (eq? '* exports)
- #t
- (caddr x))
- ,@(let ((body (cdddr x)))
- (if (and (pair? body)
- (null? (cdr body))
- (string? (car body)))
- `((##core#include ,(car body)))
- body)))))))
+ (let ((len (length x)))
+ (cond ((and (fx>= len 2) (pair? (cadr x)))
+ (##sys#check-syntax 'module x '(_ (symbol (symbol . #(_ 1))) . #(_ 0 1)))
+ (let* ((x (##sys#strip-syntax x))
+ (head (cadr x)))
+ (##sys#instantiate-functor
+ (car head)
+ (caadr head)
+ (cdadr head)
+ (if (null? (cddr x))
+ '*
+ (##sys#validate-exports (caddr x) (car head))))))
+ ((and (fx= len 3) (symbol? (cadr x)))
+ (##sys#check-syntax 'module x '(_ symbol symbol))
+ (let ((x (##sys#strip-syntax x)))
+ (##sys#register-module-alias (cadr x) (caddr x))
+ '(##core#undefined)))
+ (else
+ (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
+ ;;XXX use module name in "loc" argument?
+ (let ((exports (##sys#validate-exports (##sys#strip-syntax (caddr x)) 'module)))
+ `(##core#module
+ ,(cadr x)
+ ,(if (eq? '* exports)
+ #t
+ exports)
+ ,@(let ((body (cdddr x)))
+ (if (and (pair? body)
+ (null? (cdr body))
+ (string? (car body)))
+ `((##core#include ,(car body)))
+ body))))))))))
(##sys#extend-macro-environment
'begin-for-syntax
@@ -1394,6 +1411,8 @@
(define ##sys#default-macro-environment
(##sys#fixup-macro-environment (##sys#macro-environment)))
+(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
+
;; Used by the syntax-rules implementation (and possibly handy elsewhere)
;; (kindly contributed by Peter Bex)
@@ -1416,4 +1435,3 @@
((> len temp)
(loop (- len 1) (cdr input)))
(else input))))
-
diff --git a/modules.scm b/modules.scm
index d9fe5bde..c337a895 100644
--- a/modules.scm
+++ b/modules.scm
@@ -55,7 +55,6 @@
;;; low-level module support
-(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
(define ##sys#current-module (make-parameter #f))
(define ##sys#module-alias-environment '())
@@ -99,6 +98,17 @@
(define (make-module name explist vexports sexports)
(%make-module name explist '() '() '() '() '() '() '() vexports sexports))
+(define (##sys#register-module-alias alias name)
+ (set! ##sys#module-alias-environment
+ (cons (cons alias name) ##sys#module-alias-environment)))
+
+(define (##sys#with-module-aliases bindings thunk)
+ (fluid-let ((##sys#module-alias-environment
+ (append
+ (map (lambda (b) (cons (car b) (cadr b))) bindings)
+ ##sys#module-alias-environment)))
+ (thunk)))
+
(define (##sys#resolve-module-name name loc)
(let loop ((n name) (done '()))
(cond ((assq n ##sys#module-alias-environment) =>
@@ -715,3 +725,47 @@
(err "invalid interface specification" x exps)))
(err "invalid interface specification" x exps)))
(else (err "invalid export" x exps))))))))))
+
+(define (##sys#register-functor name fargs body)
+ (putp name '##core#functor (cons fargs body)))
+
+(define (##sys#instantiate-functor name fname args exports)
+ (let ((funcdef (getp fname '##core#functor)))
+ (define (err . args)
+ (apply ##sys#syntax-error-hook name args))
+ (unless funcdef (err "instantation of undefined functor" fname))
+ (let ((fargs (car funcdef))
+ (body (cdr funcdef)))
+ (define (merr)
+ (err "argument list mismatch in functor instantiation"
+ (cons name args) (cons fname (map car fargs))))
+ `(##core#let-module-alias
+ ,(let loop ((as args) (fas fargs))
+ (cond ((null? as) (if (null? fas) '() (merr)))
+ ((null? fas) (merr))
+ (else
+ (let* ((p (car fas))
+ (alias (car p))
+ (mname (car as))
+ (exps (cdr p)))
+ (##sys#match-functor-argument alias mname exps name)
+ (cons (list alias mname) (loop (cdr as) (cdr fas)))))))
+ (##core#module
+ ,name
+ ,(if (eq? '* exports) #t exports)
+ ,@body)))))
+
+(define (##sys#match-functor-argument alias mname exps loc)
+ (let ((mod (##sys#find-module (##sys#resolve-module-name mname loc) #t loc)))
+ (unless (eq? exps '*)
+ (let ((missing '()))
+ (for-each
+ (lambda (exp)
+ (let ((sym (if (symbol? exp) exp (car exp))))
+ (unless (##sys#find-export sym mod #f)
+ (set! missing (cons sym missing)))))
+ exps)
+ (when (pair? missing)
+ (##sys#syntax-error-hook
+ loc "argument module does not match required signature"
+ mname alias))))))
Trap