~ chicken-core (chicken-5) 0ab0a18b6a9bc7a09f82791ddacfd178f08b854a
commit 0ab0a18b6a9bc7a09f82791ddacfd178f08b854a
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Jun 17 12:05:36 2017 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Jun 18 14:49:45 2017 +0200
Add "chicken.module" module
This syntax-only library contains CHICKEN's "module language" and
currently contains: module, import[-*], export and reexport.
TODOs have been left in place to remind us to move `functor` and
`define-interface` into this module, as well.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index f43cc045..0c4db9d1 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1139,6 +1139,7 @@
;;; interface definition
+;; TODO: Move this into "chicken.module"
(##sys#extend-macro-environment
'define-interface '()
(##sys#er-transformer
@@ -1166,6 +1167,7 @@
;;; functor definition
+;; TODO: Move this into "chicken.module"
(##sys#extend-macro-environment
'functor '()
(##sys#er-transformer
diff --git a/expand.scm b/expand.scm
index 32fc7c19..57a3a5a2 100644
--- a/expand.scm
+++ b/expand.scm
@@ -975,13 +975,6 @@
##sys#current-meta-environment ##sys#meta-macro-environment
#t #f 'import-syntax-for-syntax)))
-(##sys#extend-macro-environment
- 'reexport '()
- (##sys#er-transformer
- (cut ##sys#expand-import <> <> <>
- ##sys#current-environment ##sys#macro-environment
- #f #t 'reexport)))
-
(set! chicken.expand#import-definition
(##sys#extend-macro-environment
'import '()
@@ -1001,6 +994,7 @@
`(##core#require ,lib ,(module-requirement name)))))
(cdr x)))))))
+;; TODO Move this out of the initial environment:
(##sys#extend-macro-environment
'begin-for-syntax '()
(##sys#er-transformer
@@ -1015,9 +1009,83 @@
(lambda (x r c)
`(,(r 'begin-for-syntax) (,(r 'import) ,@(cdr x))))))
-;; contains only syntax-related bindings
+;; The "initial" macro environment, containing only import forms
(define ##sys#initial-macro-environment (##sys#macro-environment))
+(##sys#extend-macro-environment
+ 'module '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'module x '(_ _ _ . #(_ 0)))
+ (let ((len (length x))
+ (name (library-id (cadr x))))
+ (cond ((and (fx>= len 4) (c (r '=) (caddr x)))
+ (let* ((x (strip-syntax x))
+ (app (cadddr x)))
+ (cond ((fx> len 4)
+ ;; feature suggested by syn:
+ ;;
+ ;; (module NAME = FUNCTORNAME BODY ...)
+ ;; ~>
+ ;; (begin
+ ;; (module _NAME * BODY ...)
+ ;; (module NAME = (FUNCTORNAME _NAME)))
+ ;;
+ ;; - the use of "_NAME" is a bit stupid, but it must be
+ ;; externally visible to generate an import library from
+ ;; and compiling "NAME" separately may need an import-lib
+ ;; for stuff in "BODY" (say, syntax needed by syntax exported
+ ;; from the functor, or something like this...)
+ (let ((mtmp (string->symbol
+ (##sys#string-append
+ "_"
+ (symbol->string name))))
+ (%module (r 'module)))
+ `(##core#begin
+ (,%module ,mtmp * ,@(cddddr x))
+ (,%module ,name = (,app ,mtmp)))))
+ (else
+ (##sys#check-syntax
+ 'module x '(_ _ _ (_ . #(_ 0))))
+ (##sys#instantiate-functor
+ name
+ (library-id (car app))
+ (cdr app)))))) ; functor arguments
+ (else
+ ;;XXX use module name in "loc" argument?
+ (let ((exports (##sys#validate-exports (strip-syntax (caddr x)) 'module)))
+ `(##core#module
+ ,name
+ ,(if (eq? '* exports)
+ #t
+ exports)
+ ,@(let ((body (cdddr x)))
+ (if (and (pair? body)
+ (null? (cdr body))
+ (string? (car body)))
+ `((##core#include ,(car body) ,##sys#current-source-filename))
+ body))))))))))
+
+(##sys#extend-macro-environment
+ 'export '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export))
+ (mod (##sys#current-module)))
+ (when mod
+ (##sys#add-to-export-list mod exps))
+ '(##core#undefined)))))
+
+(##sys#extend-macro-environment
+ 'reexport '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <>
+ ##sys#current-environment ##sys#macro-environment
+ #f #t 'reexport)))
+
+;; The chicken.module syntax environment
+(define ##sys#chicken.module-macro-environment (##sys#macro-environment))
+
(##sys#extend-macro-environment
'lambda
'()
@@ -1503,74 +1571,6 @@
(lambda (x r c)
`(,(r 'begin-for-syntax) (,(r 'require-extension) ,@(cdr x))))))
-(##sys#extend-macro-environment
- 'module
- '()
- (##sys#er-transformer
- (lambda (x r c)
- (##sys#check-syntax 'module x '(_ _ _ . #(_ 0)))
- (let ((len (length x))
- (name (library-id (cadr x))))
- (cond ((and (fx>= len 4) (c (r '=) (caddr x)))
- (let* ((x (strip-syntax x))
- (app (cadddr x)))
- (cond ((fx> len 4)
- ;; feature suggested by syn:
- ;;
- ;; (module NAME = FUNCTORNAME BODY ...)
- ;; ~>
- ;; (begin
- ;; (module _NAME * BODY ...)
- ;; (module NAME = (FUNCTORNAME _NAME)))
- ;;
- ;; - the use of "_NAME" is a bit stupid, but it must be
- ;; externally visible to generate an import library from
- ;; and compiling "NAME" separately may need an import-lib
- ;; for stuff in "BODY" (say, syntax needed by syntax exported
- ;; from the functor, or something like this...)
- (let ((mtmp (string->symbol
- (##sys#string-append
- "_"
- (symbol->string name))))
- (%module (r 'module)))
- `(##core#begin
- (,%module ,mtmp * ,@(cddddr x))
- (,%module ,name = (,app ,mtmp)))))
- (else
- (##sys#check-syntax
- 'module x '(_ _ _ (_ . #(_ 0))))
- (##sys#instantiate-functor
- name
- (library-id (car app))
- (cdr app)))))) ; functor arguments
- (else
- ;;XXX use module name in "loc" argument?
- (let ((exports
- (##sys#validate-exports (strip-syntax (caddr x)) 'module)))
- `(##core#module
- ,name
- ,(if (eq? '* exports)
- #t
- exports)
- ,@(let ((body (cdddr x)))
- (if (and (pair? body)
- (null? (cdr body))
- (string? (car body)))
- `((##core#include ,(car body) ,##sys#current-source-filename))
- body))))))))))
-
-(##sys#extend-macro-environment
- 'export
- '()
- (##sys#er-transformer
- (lambda (x r c)
- (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export))
- (mod (##sys#current-module)))
- (when mod
- (##sys#add-to-export-list mod exps))
- '(##core#undefined)))))
-
-
;;; syntax-rules
(include "synrules.scm")
diff --git a/modules.scm b/modules.scm
index 4470a1b6..0b818904 100644
--- a/modules.scm
+++ b/modules.scm
@@ -985,6 +985,9 @@
(define-inline (se-subset names env) (map (cut assq <> env) names))
+(##sys#register-core-module
+ 'chicken.module #f '() ##sys#chicken.module-macro-environment)
+
(##sys#register-primitive-module
'srfi-0 '() (se-subset '(cond-expand) ##sys#default-macro-environment))
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 8d109e6e..1858da58 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -116,6 +116,7 @@
(module (2x noop) = ((double printer) (noop printer)))
(module (2x write) = (double printer)
+ (import (chicken module))
(reexport (rename (scheme) (write print))))
(define output
diff --git a/tests/reexport-m1.scm b/tests/reexport-m1.scm
index a49fdc58..bca452cd 100644
--- a/tests/reexport-m1.scm
+++ b/tests/reexport-m1.scm
@@ -1,5 +1,5 @@
;;;; module re-exporting from core module
(module reexport-m1 ()
- (import scheme chicken)
+ (import (chicken module))
(reexport (only srfi-4 u8vector)))
diff --git a/tests/reexport-m4.scm b/tests/reexport-m4.scm
index 4f18ef68..08ea5d07 100644
--- a/tests/reexport-m4.scm
+++ b/tests/reexport-m4.scm
@@ -2,7 +2,7 @@
(module
reexport-m4
(baz)
- (import chicken scheme reexport-m3)
+ (import chicken scheme (chicken module) reexport-m3)
(reexport reexport-m3)
(define-syntax baz
(ir-macro-transformer
diff --git a/tests/reexport-m6.scm b/tests/reexport-m6.scm
index 803b9b8f..89566f86 100644
--- a/tests/reexport-m6.scm
+++ b/tests/reexport-m6.scm
@@ -1,2 +1,3 @@
(module reexport-m6 ()
+(import (chicken module))
(reexport (prefix reexport-m5 f:)))
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
index 025c853f..7a74cb06 100644
--- a/tests/reexport-tests.scm
+++ b/tests/reexport-tests.scm
@@ -2,8 +2,8 @@
(module my-r4rs ()
- (import scheme chicken)
- (reexport
+ (import (chicken module))
+ (reexport
(except scheme
dynamic-wind values call-with-values eval scheme-report-environment
null-environment interaction-environment)))
@@ -24,7 +24,7 @@
(syntax-rules ()
((_ name imp ...)
(module name ()
- (import scheme imp ...)
+ (import (chicken module) imp ...)
(reexport imp ...)))))
(compound-module
@@ -49,7 +49,7 @@
(module
m5
* ; () works here
- (import chicken scheme m4)
+ (import (chicken module) m4)
(reexport m4))
(import m5)
Trap