~ chicken-core (chicken-5) 14f7eb30207e801072e26bcd818180496dc397d4
commit 14f7eb30207e801072e26bcd818180496dc397d4
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Jul 8 21:14:44 2015 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 8 21:14:44 2015 +1200
Convert the expand unit into a module
diff --git a/batch-driver.scm b/batch-driver.scm
index a4ab276b..82351f9d 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -178,7 +178,8 @@
arg) ) ) )
(initialize-compiler)
(set! explicit-use-flag (memq 'explicit-use options))
- (let ((initforms `((import scheme chicken)
+ (let ((initforms `((import-for-syntax scheme chicken)
+ (import scheme chicken)
(##core#declare
,@(append
default-declarations
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index eaba3ab2..2063d8cc 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -27,6 +27,7 @@
(declare
(unit chicken-syntax)
+ (uses expand)
(disable-interrupts)
(fixnum) )
@@ -78,7 +79,7 @@
(null? (cddr slot)))
(cadr slot))
(else
- (syntax-error
+ (chicken.expand#syntax-error
'define-record "invalid slot specification" slot))))
slots)))
`(##core#begin
@@ -180,7 +181,7 @@
(msg (optional msg-and-args "assertion failed"))
(tmp (r 'tmp)))
(when (string? msg)
- (and-let* ((ln (get-line-number form)))
+ (and-let* ((ln (chicken.expand#get-line-number form)))
(set! msg (string-append "(" ln ") " msg))))
`(##core#let ((,tmp ,exp))
(##core#if (##core#check ,tmp)
@@ -460,7 +461,7 @@
(when (or (not (pair? val))
(and (not (eq? '##core#lambda (car val)))
(not (c (r 'lambda) (car val)))))
- (syntax-error
+ (chicken.expand#syntax-error
'define-inline "invalid substitution form - must be lambda"
name val) )
(list name val) ) ) ] )
@@ -502,7 +503,7 @@
(cond ((null? clauses)
'(##core#undefined) )
((not (pair? clauses))
- (syntax-error 'select "invalid syntax" clauses))
+ (chicken.expand#syntax-error 'select "invalid syntax" clauses))
(else
(let ((clause (##sys#slot clauses 0))
(rclauses (##sys#slot clauses 1)) )
@@ -979,7 +980,7 @@
(%<...> (r '<...>))
(%apply (r 'apply)))
(when (null? (cdr form))
- (syntax-error 'cut "you need to supply at least a procedure" form))
+ (chicken.expand#syntax-error 'cut "you need to supply at least a procedure" form))
(let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
(if (null? xs)
(let ([rvars (reverse vars)]
@@ -995,11 +996,12 @@
(let ([v (r (gensym))])
(loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
((c %<...> (car xs))
- (if (null? (cdr xs))
- (loop '() vars vals #t)
- (syntax-error 'cut
- "tail patterns after <...> are not supported"
- form)))
+ (if (null? (cdr xs))
+ (loop '() vars vals #t)
+ (chicken.expand#syntax-error
+ 'cut
+ "tail patterns after <...> are not supported"
+ form)))
(else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
(##sys#extend-macro-environment
@@ -1011,7 +1013,7 @@
(%<> (r '<>))
(%<...> (r '<...>)))
(when (null? (cdr form))
- (syntax-error 'cute "you need to supply at least a procedure" form))
+ (chicken.expand#syntax-error 'cute "you need to supply at least a procedure" form))
(let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
(if (null? xs)
(let ([rvars (reverse vars)]
@@ -1028,11 +1030,12 @@
(let ([v (r (gensym))])
(loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
((c %<...> (car xs))
- (if (null? (cdr xs))
- (loop '() vars bs vals #t)
- (syntax-error 'cute
- "tail patterns after <...> are not supported"
- form)))
+ (if (null? (cdr xs))
+ (loop '() vars bs vals #t)
+ (chicken.expand#syntax-error
+ 'cute
+ "tail patterns after <...> are not supported"
+ form)))
(else
(let ([v (r (gensym))])
(loop (cdr xs)
@@ -1183,7 +1186,7 @@
type1
(##sys#strip-syntax name1))))
(cond ((not type)
- (syntax-error ': "invalid type syntax" name1 type1))
+ (chicken.expand#syntax-error ': "invalid type syntax" name1 type1))
(else
`(##core#declare
(type (,name1 ,type1 ,@(cdddr x)))
@@ -1270,7 +1273,7 @@
(cadr arg)
'define-specialization)
atypes)))
- (else (syntax-error
+ (else (chicken.expand#syntax-error
'define-specialization
"invalid argument syntax" arg head)))))))))))))
@@ -1281,7 +1284,7 @@
(##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
(let ((val (memq #:compiling ##sys#features))
(var (gensym))
- (ln (get-line-number x)))
+ (ln (chicken.expand#get-line-number x)))
`(##core#let ((,var ,(cadr x)))
(##core#typecase
,ln
diff --git a/chicken.import.scm b/chicken.import.scm
index 7ecd469e..339e6fa5 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -71,7 +71,7 @@
(dynamic-load-libraries . chicken.eval#dynamic-load-libraries)
enable-warnings
equal=?
- er-macro-transformer
+ (er-macro-transformer . chicken.expand#er-macro-transformer)
errno
error
(eval-handler . chicken.eval#eval-handler)
@@ -80,7 +80,7 @@
exact-integer-nth-root
exit
exit-handler
- expand
+ (expand . chicken.expand#expand)
(extension-information . chicken.eval#extension-information)
feature?
features
@@ -165,13 +165,14 @@
get-condition-property
get-environment-variable
get-keyword
+ (get-line-number . chicken.expand#get-line-number)
get-output-string
get-properties
getter-with-setter
implicit-exit-handler
infinite?
integer-length
- ir-macro-transformer
+ (ir-macro-transformer . chicken.expand#ir-macro-transformer)
keyword->string
keyword-style
keyword?
@@ -239,20 +240,18 @@
string->blob
string->keyword
string->uninterned-symbol
- strip-syntax
+ (strip-syntax . chicken.expand#strip-syntax)
sub1
subvector
symbol-append
symbol-escape
symbol-plist
- syntax-error
+ (syntax-error . chicken.expand#syntax-error)
system
unregister-feature!
vector-resize
vector-copy!
void
warning
- er-macro-transformer
- ir-macro-transformer
with-exception-handler)
##sys#chicken-macro-environment) ;XXX incorrect - won't work in compiled executable that does expansion
diff --git a/csi.scm b/csi.scm
index 11743c5c..024550e7 100644
--- a/csi.scm
+++ b/csi.scm
@@ -26,7 +26,7 @@
(declare
- (uses data-structures eval extras ports)
+ (uses data-structures eval expand extras ports)
(usual-integrations)
(disable-interrupts)
(compile-syntax)
@@ -1091,6 +1091,7 @@ EOF
;; Load the the default modules into the evaluation environment.
;; This is done before setting load-verbose => #t to avoid
;; spurious import messages.
+ (eval '(import-for-syntax scheme chicken))
(eval '(import scheme chicken))
(unless quiet
(load-verbose #t)
diff --git a/defaults.make b/defaults.make
index 85bfd270..07e7549c 100644
--- a/defaults.make
+++ b/defaults.make
@@ -271,7 +271,7 @@ PRIMITIVE_IMPORT_LIBRARIES = chicken srfi-4
PRIMITIVE_IMPORT_LIBRARIES += csi setup-api setup-download
POSIX_IMPORT_LIBRARY = posix
FOREIGN_IMPORT_LIBRARY = foreign
-DYNAMIC_IMPORT_LIBRARIES = data-structures eval extras files irregex lolevel ports tcp utils
+DYNAMIC_IMPORT_LIBRARIES = data-structures eval expand extras files irregex lolevel ports tcp utils
# targets
diff --git a/distribution/manifest b/distribution/manifest
index 58ed9135..ca5169f9 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -242,6 +242,8 @@ chicken.data-structures.import.scm
chicken.data-structures.import.c
chicken.eval.import.scm
chicken.eval.import.c
+chicken.expand.import.scm
+chicken.expand.import.c
chicken.extras.import.scm
chicken.extras.import.c
chicken.files.import.scm
diff --git a/expand.scm b/expand.scm
index d926151d..3eda4d89 100644
--- a/expand.scm
+++ b/expand.scm
@@ -31,14 +31,19 @@
(unit expand)
(disable-interrupts)
(fixnum)
- (hide match-expression
- macro-alias
- check-for-multiple-bindings
- d dd dm dx map-se
- lookup check-for-redef)
(not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
##sys#toplevel-definition-hook))
+(module chicken.expand
+ (expand
+ get-line-number
+ strip-syntax
+ syntax-error
+ er-macro-transformer
+ ir-macro-transformer)
+
+(import scheme chicken)
+
(include "common-declarations.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -918,6 +923,7 @@
(define ##sys#er-transformer er-macro-transformer)
(define ##sys#ir-transformer ir-macro-transformer)
+) ; chicken.expand module
;;; Macro definitions:
@@ -1173,7 +1179,7 @@
(##sys#srfi-4-vector? (car clause))
(and (pair? (car clause))
(c (r 'quote) (caar clause))))
- (expand rclauses (strip-syntax (car clause)))
+ (expand rclauses (chicken.expand#strip-syntax (car clause)))
(cond ((and (fx= (length clause) 3)
(c %=> (cadr clause)))
`(,(caddr clause) ,(car clause)))
@@ -1324,16 +1330,16 @@
(else
`(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
(define (simplify x)
- (cond ((match-expression x '(##sys#cons a (##core#quote ())) '(a))
+ (cond ((chicken.expand#match-expression x '(##sys#cons a (##core#quote ())) '(a))
=> (lambda (env) (simplify `(##sys#list ,(cdr (assq 'a env))))) )
- ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
+ ((chicken.expand#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
=> (lambda (env)
(let ((bxs (assq 'b env)))
(if (fx< (length bxs) 32)
(simplify `(##sys#list ,(cdr (assq 'a env))
,@(cdr bxs) ) )
x) ) ) )
- ((match-expression x '(##sys#append a (##core#quote ())) '(a))
+ ((chicken.expand#match-expression x '(##sys#append a (##core#quote ())) '(a))
=> (lambda (env) (cdr (assq 'a env))) )
(else x) ) )
(##sys#check-syntax 'quasiquote form '(_ _))
diff --git a/modules.scm b/modules.scm
index 241a88b0..d6989c27 100644
--- a/modules.scm
+++ b/modules.scm
@@ -26,7 +26,7 @@
(declare
(unit modules)
- (uses eval)
+ (uses eval expand)
(disable-interrupts)
(fixnum)
(hide lookup merge-se module-indirect-exports)
diff --git a/rules.make b/rules.make
index 8425226c..613e981d 100644
--- a/rules.make
+++ b/rules.make
@@ -683,7 +683,7 @@ library.c: $(SRCDIR)library.scm $(SRCDIR)banner.scm $(SRCDIR)common-declarations
eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib) -emit-import-library chicken.eval
expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
+ $(bootstrap-lib) -emit-import-library chicken.expand
modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib)
extras.c: $(SRCDIR)extras.scm $(SRCDIR)common-declarations.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index dc5c2526..d1c6fb6a 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -26,7 +26,7 @@
(declare
(unit scrutinizer)
- (uses data-structures eval extras ports files support))
+ (uses data-structures eval expand extras ports files support))
(module chicken.compiler.scrutinizer
(scrutinize load-type-database emit-type-file
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 9c72dc76..3e5462ac 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -42,17 +42,17 @@ Warning: at toplevel:
(scrutiny-tests.scm:29) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a183) (procedure car ((pair a183 *)) a183))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a188) (procedure car ((pair a188 *)) a188))'
Warning: at toplevel:
- expected in `let' binding of `g15' a single result, but were given 2 results
+ expected in `let' binding of `g20' a single result, but were given 2 results
Warning: at toplevel:
- in procedure call to `g15', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+ in procedure call to `g20', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Note: in toplevel procedure `foo':
expected value of type boolean in conditional but were given a value of type
- `(procedure bar37 () *)' which is always true:
+ `(procedure bar42 () *)' which is always true:
(if bar 3 (##core#undefined))
diff --git a/types.db b/types.db
index 979ebb63..67c05d22 100644
--- a/types.db
+++ b/types.db
@@ -976,9 +976,9 @@
((* (or symbol char eof null undefined)) (eq? #(1) #(2)))
((number number) (= #(1) #(2))))
-(er-macro-transformer
+(chicken.expand#er-macro-transformer
(#(procedure #:clean #:enforce)
- er-macro-transformer
+ chicken.expand#er-macro-transformer
((procedure (* (procedure (*) *) (procedure (* *) *)) *))
(struct transformer)))
@@ -989,7 +989,7 @@
(executable-pathname (#(procedure #:pure) executable-pathname () (or string false)))
(exit (procedure exit (#!optional fixnum) noreturn))
(exit-handler (#(procedure #:clean #:enforce) exit-handler (#!optional (procedure (fixnum) . *)) procedure))
-(expand (procedure expand (* #!optional list) *))
+(chicken.expand#expand (procedure chicken.expand#expand (* #!optional list) *))
(chicken.eval#extension-information (#(procedure #:clean) chicken.eval#extension-information (symbol) *))
(feature? (#(procedure #:clean) feature? (#!rest symbol) boolean))
(features (#(procedure #:clean) features () (list-of symbol)))
@@ -1173,9 +1173,9 @@
(implicit-exit-handler
(#(procedure #:clean #:enforce) implicit-exit-handler (#!optional (procedure () . *)) procedure))
-(ir-macro-transformer
+(chicken.expand#ir-macro-transformer
(#(procedure #:clean #:enforce)
- ir-macro-transformer
+ chicken.expand#ir-macro-transformer
((procedure (* (procedure (*) *) (procedure (* *) *)) *))
(struct transformer)))
@@ -1279,7 +1279,7 @@
(string->blob (#(procedure #:clean #:enforce) string->blob (string) blob))
(string->keyword (#(procedure #:clean #:enforce) string->keyword (string) symbol))
(string->uninterned-symbol (#(procedure #:clean #:enforce) string->uninterned-symbol (string) symbol))
-(strip-syntax (#(procedure #:clean) strip-syntax (*) *))
+(chicken.expand#strip-syntax (#(procedure #:clean) chicken.expand#strip-syntax (*) *))
(sub1 (#(procedure #:clean #:enforce #:foldable) sub1 (number) number)
((fixnum) (integer)
@@ -1297,7 +1297,7 @@
(symbol-plist (#(procedure #:clean #:enforce) symbol-plist (symbol) list)
((symbol) (##sys#slot #(1) '2)))
-(syntax-error (procedure syntax-error (* #!rest) noreturn))
+(chicken.expand#syntax-error (procedure chicken.expand#syntax-error (* #!rest) noreturn))
(system (#(procedure #:clean #:enforce) system (string) fixnum))
(unregister-feature! (#(procedure #:clean #:enforce) unregister-feature! (#!rest symbol) undefined))
(vector-resize
Trap