~ chicken-core (chicken-5) 4102bd0057eeab69d53c06d754e286089f8383f3
commit 4102bd0057eeab69d53c06d754e286089f8383f3
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Mar 19 09:16:12 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Mar 19 09:16:12 2011 +0100
module aliases
diff --git a/compiler.scm b/compiler.scm
index 0ba5b4a0..5ddc5608 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -143,6 +143,7 @@
; (##core#define-compiler-syntax <symbol> <expr>)
; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
+; (##core#let-module-alias ((<alias> <name>) ...) <body>)
; (<exp> {<exp>})
; - Core language:
@@ -806,9 +807,18 @@
(##sys#include-forms-from-file (cadr x))))
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)))
+
((##core#module)
(let* ((x (##sys#strip-syntax x))
- (name (##sys#strip-syntax (cadr x)))
+ (name (cadr x))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -823,7 +833,7 @@
(##sys#syntax-error-hook
'module
"invalid export syntax" exp name))))
- (##sys#strip-syntax (caddr x)))))
+ (caddr x))))
(csyntax compiler-syntax))
(when (##sys#current-module)
(##sys#syntax-error-hook
diff --git a/csi.scm b/csi.scm
index 7552df83..705e6beb 100644
--- a/csi.scm
+++ b/csi.scm
@@ -434,7 +434,7 @@ EOF
(set! name (##sys#string->symbol name)))
((not (symbol? name))
(printf "invalid module name `~a'~%" name))
- ((##sys#find-module name #f) =>
+ ((##sys#find-module (##sys#resolve-module-name name #f) #f) =>
(lambda (m)
(##sys#current-module m)
(printf "; switching current module to `~a'~%" name)))
diff --git a/eval.scm b/eval.scm
index d08f3426..d482c12e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -614,9 +614,18 @@
,@(##sys#include-forms-from-file (cadr x)))
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)))
+
((##core#module)
(let* ((x (##sys#strip-syntax x))
- (name (##sys#strip-syntax (cadr x)))
+ (name (cadr x))
(exports
(or (eq? #t (caddr x))
(map (lambda (exp)
@@ -631,7 +640,7 @@
(##sys#syntax-error-hook
'module
"invalid export syntax" exp name))))
- (##sys#strip-syntax (caddr x))))))
+ (caddr x)))))
(when (##sys#current-module)
(##sys#syntax-error-hook 'module "modules may not be nested" name))
(parameterize ((##sys#current-module
@@ -646,12 +655,12 @@
(let loop2 ((xs xs))
(if (null? xs)
(##sys#void)
- (let ((n (##sys#slot xs 1)))
+ (let ((n (cdr xs)))
(cond ((pair? n)
- ((##sys#slot xs 0) v)
+ ((car xs) v)
(loop2 n))
(else
- ((##sys#slot xs 0) v))))))))
+ ((car xs) v))))))))
(loop
(cdr body)
(cons (compile
diff --git a/expand.scm b/expand.scm
index 7e1e3467..e6fc4769 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1312,8 +1312,10 @@
'()
(##sys#er-transformer
(lambda (x r c)
+ ;;XXX module alias + functor application
(##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
- (let ((exports (##sys#validate-exports (##sys#strip-syntax (caddr x)) (cadr x))))
+ ;;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)
diff --git a/modules.scm b/modules.scm
index a4db59f9..d9fe5bde 100644
--- a/modules.scm
+++ b/modules.scm
@@ -57,6 +57,7 @@
(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
(define ##sys#current-module (make-parameter #f))
+(define ##sys#module-alias-environment '())
(declare
(hide make-module module? %make-module
@@ -98,9 +99,19 @@
(define (make-module name explist vexports sexports)
(%make-module name explist '() '() '() '() '() '() '() vexports sexports))
-(define (##sys#find-module name #!optional (err #t))
+(define (##sys#resolve-module-name name loc)
+ (let loop ((n name) (done '()))
+ (cond ((assq n ##sys#module-alias-environment) =>
+ (lambda (a)
+ (let ((n2 (cdr a)))
+ (if (memq n2 done)
+ (error loc "module alias refers to itself" name)
+ (loop n2 (cons n2 done))))))
+ (else n))))
+
+(define (##sys#find-module name #!optional (err #t) loc)
(cond ((assq name ##sys#module-table) => cdr)
- (err (error 'import "module not found" name))
+ (err (error loc "module not found" name))
(else #f)))
(define (##sys#toplevel-definition-hook sym mod exp val) #f)
@@ -485,10 +496,10 @@
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
(define (import-name spec)
- (let* ((mname (##sys#strip-syntax spec))
- (mod (##sys#find-module mname #f)))
+ (let* ((mname (##sys#resolve-module-name (##sys#strip-syntax spec) 'import))
+ (mod (##sys#find-module mname #f 'import)))
(unless mod
- (let ((il (##sys#find-extension
+ (let* ((il (##sys#find-extension
(string-append (symbol->string mname) ".import")
#t)))
(cond (il (parameterize ((##sys#current-module #f)
@@ -499,7 +510,7 @@
(##sys#meta-macro-environment)))
(fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
(##sys#load il #f #f)))
- (set! mod (##sys#find-module mname)))
+ (set! mod (##sys#find-module mname 'import)))
(else
(##sys#syntax-error-hook
loc "cannot import from undefined module"
Trap