~ chicken-core (chicken-5) 0bc75263a0f69b6a661d2a1a91deaea06aee3a90
commit 0bc75263a0f69b6a661d2a1a91deaea06aee3a90
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Apr 28 22:52:13 2018 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Apr 29 00:02:36 2018 +0200
Add `current-module' helper macro to "chicken.module"
This special form returns the name of the module currently being
compiled (or evaluated) as a symbol.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken-install.scm b/chicken-install.scm
index 74108643..25f735ac 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -929,7 +929,7 @@
(sprintf "Failed to import from `~a'" file))
(eval `(import-syntax ,(string->symbol module-name))))))
files))
- (print "generating database")
+ (print "generating database ...")
(let ((db
(sort
(concatenate
@@ -938,14 +938,12 @@
(and-let* ((mod (cdr m))
(mname (##sys#module-name mod))
((not (memq mname +internal-modules+))))
- (print* " " mname)
(let-values (((_ ve se) (##sys#module-exports mod)))
(append (map (lambda (se) (list (car se) 'syntax mname)) se)
(map (lambda (ve) (list (car ve) 'value mname)) ve)))))
##sys#module-table))
(lambda (e1 e2)
(string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
- (newline)
(with-output-to-file dbfile
(lambda ()
(for-each (lambda (x) (write x) (newline)) db)))
diff --git a/expand.scm b/expand.scm
index d3fcdbbe..d0a7aca6 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1184,6 +1184,14 @@
(syntax-error-hook
'define-interface "invalid exports" (caddr x))))))))))))
+(##sys#extend-macro-environment
+ 'current-module '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'current-module x '(_))
+ (and-let* ((mod (##sys#current-module)))
+ `(##core#quote ,(##sys#module-name mod))))))
+
;; The chicken.module syntax environment
(define ##sys#chicken.module-macro-environment (##sys#macro-environment))
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index 83f142d0..ec447e45 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -372,6 +372,14 @@
"Internal getter returns same thing"
3 (get-count))
+(test-assert
+ (not (current-module)))
+
+(test-assert
+ (module m33 ()
+ (import (scheme) (chicken module))
+ (eq? (current-module) 'm33)))
+
(test-end "modules")
(test-exit)
Trap