Welcome to the CHICKEN Scheme pasting service
fun times pasted by megane on Thu Jul 19 09:50:57 2018
Error: (map) bad argument type - not a proper list: (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rules (((syntax-rule... Call history: library.scm:2289: body3899 library.scm:2291: assign library.scm:3447: current-print-length53155316 library.scm:2289: body3899 library.scm:2291: assign library.scm:1694: ##sys#dynamic-unwind library.scm:3924: ##sys#print library.scm:3187: case-sensitive library.scm:3188: keyword-style library.scm:3189: ##sys#print-length-limit library.scm:3296: outchr library.scm:3187: g5024 library.scm:3925: print-call-chain library.scm:3880: ##sys#get-call-chain library.scm:3832: ##sys#make-vector library.scm:1370: ##sys#allocate-vector <-- example of compile options: chicken expand.scm -optimize-level 0 -debug-level 2 -include-path . -include-path ./ -ignore-repository -feature chicken-bootstrap -feature debugbuild -verbose -debug-info -specialize -types ./types.db -explicit-use -output-file expand.c gcc -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -c -g -Wall -Wno-unused -DC_BUILDING_LIBCHICKEN expand.c -o expand-static.o -I. -I./
disappearing call chain pasted by megane on Thu Jul 19 09:58:18 2018
(error "foo") --> Error: foo Call history: library.scm:3447: print-exit53135314 library.scm:2289: body3899 library.scm:2291: assign library.scm:3447: current-print-length53155316 library.scm:2289: body3899 library.scm:2291: assign library.scm:3924: ##sys#print library.scm:3187: case-sensitive library.scm:3188: keyword-style library.scm:3189: ##sys#print-length-limit library.scm:3296: outchr library.scm:3187: g5024 library.scm:3925: print-call-chain library.scm:3880: ##sys#get-call-chain library.scm:3832: ##sys#make-vector library.scm:1370: ##sys#allocate-vector <-- (print-call-chain) (error "foo") --> Call history: library.scm:2289: def-convert?3901 library.scm:2289: def-set?3902 library.scm:2289: body3899 library.scm:2291: assign library.scm:2271: guard expand.scm:1545: ##sys#macro-environment expand.scm:1545: ##sys#fixup-macro-environment expand.scm:1533: se-for-each ses.scm:42: real-se? for-each library.scm:1589: p expand.scm:1540: merge-se ses.scm:22: print-call-chain library.scm:3880: ##sys#get-call-chain library.scm:3832: ##sys#make-vector library.scm:1370: ##sys#allocate-vector <-- Error: foo Call history: library.scm:3447: print-exit53135314 library.scm:2289: body3899 library.scm:2291: assign library.scm:3447: current-print-length53155316 library.scm:2289: body3899 library.scm:2291: assign library.scm:3924: ##sys#print library.scm:3187: case-sensitive library.scm:3188: keyword-style library.scm:3189: ##sys#print-length-limit library.scm:3296: outchr library.scm:3187: g5024 library.scm:3925: print-call-chain library.scm:3880: ##sys#get-call-chain library.scm:3832: ##sys#make-vector library.scm:1370: ##sys#allocate-vector <--
ready to ship! added by megane on Sat Jul 21 19:52:33 2018
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 6757b78..4816070 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -40,7 +40,7 @@
(define ##sys#chicken-ffi-macro-environment
- (let ((me0 (##sys#macro-environment)))
+ (let ((me0 (se-derive-new (##sys#macro-environment))))
(##sys#extend-macro-environment
'define-external
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 11482bb..fc36b47 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -37,11 +37,12 @@
(##sys#provide 'chicken-syntax)
+(include "ses.scm")
;;; Non-standard macros:
(define ##sys#chicken-macro-environment
- (let ((me0 (##sys#macro-environment)))
+ (let ((me0 (se-derive-new (##sys#macro-environment))))
(##sys#extend-macro-environment
'define-constant
@@ -1233,10 +1234,10 @@
(##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
(let* ((head (cadr x))
(name (car head))
- (gname (##sys#globalize name '())) ;XXX correct?
+ (gname (##sys#globalize name (make-se))) ;XXX correct?
(args (cdr head))
(alias (gensym name))
- (galias (##sys#globalize alias '())) ;XXX and this?
+ (galias (##sys#globalize alias (make-se))) ;XXX and this?
(rtypes (and (pair? (cdddr x)) (##sys#strip-syntax (caddr x))))
(%define (r 'define))
(body (if rtypes (cadddr x) (caddr x))))
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 9e88947..8186b9e 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -30,6 +30,7 @@
(include "compiler-namespace")
(include "tweaks.scm")
+(include "ses.scm")
;;; Compiler macros (that operate in the expansion phase)
@@ -46,7 +47,7 @@
(let ((t (cons (##sys#ensure-transformer
(##sys#er-transformer transformer)
(car names))
- (append se ##sys#default-macro-environment))))
+ (se-append (make-se se) ##sys#default-macro-environment))))
(for-each
(lambda (name)
(##sys#put! name '##compiler#compiler-syntax t) )
diff --git a/compiler.scm b/compiler.scm
index 44fd24e..f2867fb 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -270,6 +270,7 @@
(include "compiler-namespace")
+(include "ses.scm")
(define (d arg1 . more)
(when (##sys#fudge 13) ; debug mode?
@@ -404,17 +405,9 @@
;;; Expand macros and canonicalize expressions:
(define (canonicalize-expression exp)
- (let ((compiler-syntax '()))
+ (let ((se-compiler-syntax '())) ; (id . old-compiler-syntax-entry)
- (define (find-id id se) ; ignores macro bindings
- (cond ((null? se) #f)
- ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
- (else (find-id id (cdr se)))))
-
- (define (lookup id se)
- (cond ((find-id id se))
- ((##sys#get id '##core#macro-alias))
- (else id)))
+ (define lookup se-rename)
(define (macro-alias var se)
(let ((alias (gensym var)))
@@ -493,6 +486,7 @@
(print "\n;; END OF FILE"))))) ) )
(define (walk x e se dest ldest h outer-ln)
+ (assert (real-se? se))
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
@@ -684,7 +678,7 @@
(set-real-names! aliases vars)
(cond ((or (not dest)
ldest
- (assq dest se)) ; not global?
+ (se-assq dest se)) ; not global?
l)
((and emit-profile
(or (eq? profiled-procedures 'all)
@@ -699,15 +693,15 @@
(else l)))))))
((##core#let-syntax)
- (let ((se2 (append
- (map (lambda (b)
- (list
- (car b)
- se
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (car b))))
- (cadr x) )
+ (let ((se2 (se-append
+ (make-se (map (lambda (b)
+ (list
+ (car b)
+ se
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (car b))))
+ (cadr x) ))
se) ) )
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
@@ -715,16 +709,17 @@
dest ldest h ln) ) )
((##core#letrec-syntax)
- (let* ((ms (map (lambda (b)
- (list
- (car b)
- #f
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (car b))))
- (cadr x) ) )
- (se2 (append ms se)) )
- (for-each
+ (let* ((ms (make-se
+ (map (lambda (b)
+ (list
+ (car b)
+ #f
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (car b))))
+ (cadr x) )) )
+ (se2 (se-append ms se)) )
+ (se-for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
ms)
@@ -762,11 +757,12 @@
(body (caddr x))
(name (lookup var se)))
(when body
- (set! compiler-syntax
- (alist-cons
- name
- (##sys#get name '##compiler#compiler-syntax)
- compiler-syntax)))
+ (set! se-compiler-syntax
+ (cons
+ (cons name
+ (##sys#get name '##compiler#compiler-syntax))
+ se-compiler-syntax)))
+ (assert (valid-se? (##sys#current-environment)))
(##sys#put!
name '##compiler#compiler-syntax
(and body
@@ -856,14 +852,14 @@
'module
"invalid export syntax" exp name))))
(##sys#strip-syntax (caddr x)))))
- (csyntax compiler-syntax))
+ (csyntax se-compiler-syntax))
(when (##sys#current-module)
(##sys#syntax-error-hook
'module "modules may not be nested" name))
(let-values (((body mreg)
(parameterize ((##sys#current-module
(##sys#register-module name exports) )
- (##sys#current-environment '())
+ (##sys#current-environment (make-se))
(##sys#macro-environment
##sys#initial-macro-environment)
(##sys#module-alias-environment
@@ -924,10 +920,10 @@
(##sys#current-meta-environment) #f #f h ln) )
mreg))
body))))
- (do ((cs compiler-syntax (cdr cs)))
+ (do ((cs se-compiler-syntax (cdr cs)))
((eq? cs csyntax))
(##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs)))
- (set! compiler-syntax csyntax)
+ (set! se-compiler-syntax csyntax)
body))))
((##core#loop-lambda) ;XXX is this really needed?
@@ -992,7 +988,7 @@
(if ln (sprintf "(~a)" ln) "") ))
(when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
((and ##sys#notices-enabled
- (assq var (##sys#current-environment)))
+ (se-assq var (##sys#current-environment)))
(##sys#notice "assignment to imported value binding" var)))
(when (keyword? var)
(warning (sprintf "assignment to keyword `~S'" var) ))
@@ -1133,7 +1129,7 @@
`((##core#set! ,alias ,init))
'() )
,(if init (fifth x) (fourth x)) ) )
- e (alist-cons var alias se)
+ e (se-cons var alias se)
dest ldest h ln) ) )
((##core#define-inline)
@@ -1182,7 +1178,7 @@
(lambda (id)
(memq (lookup id se) e))))
(cdr x) ) )
- e '() #f #f h ln) )
+ e (make-se) #f #f h ln) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -2427,7 +2423,8 @@
(else rest) ) ) )
(fourth params) )
(list (let ((body (transform (car subs) cvar capturedvars)))
- (if (pair? boxedvars)
+ ;; TODO: HACK should be (pair? boxedvars)
+ (if (pair? boxedaliases)
(fold-right
(lambda (alias val body)
(make-node 'let (list alias) (list val body)))
diff --git a/defaults.make b/defaults.make
index d6ee531..9719409 100644
--- a/defaults.make
+++ b/defaults.make
@@ -239,7 +239,7 @@ CSI ?= csi$(EXE)
# Scheme compiler flags
-CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR) -inline -ignore-repository -feature chicken-bootstrap
+CHICKEN_OPTIONS = -optimize-level 0 -debug-level 2 -include-path . -include-path $(SRCDIR) -ignore-repository -feature chicken-bootstrap
ifdef DEBUGBUILD
CHICKEN_OPTIONS += -feature debugbuild -verbose -debug-info
else
@@ -249,16 +249,16 @@ ifndef BUILDING_CHICKEN_BOOT
CHICKEN_OPTIONS += -specialize -types $(SRCDIR)types.db
endif
CHICKEN_OPTIONS += $(EXTRA_CHICKEN_OPTIONS)
-CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use -no-trace
-CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -local
-CHICKEN_COMPILER_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -extend private-namespace.scm
+CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use # -no-trace
+CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) # -no-lambda-info -local
+CHICKEN_COMPILER_OPTIONS = $(CHICKEN_OPTIONS) -extend private-namespace.scm # -no-lambda-info
CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
-CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS) -no-trace
+CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS) # -no-trace
-ifndef DEBUGBUILD
-CHICKEN_PROGRAM_OPTIONS += -no-trace
-CHICKEN_COMPILER_OPTIONS += -no-trace
-endif
+# ifndef DEBUGBUILD
+# CHICKEN_PROGRAM_OPTIONS += -no-trace
+# CHICKEN_COMPILER_OPTIONS += -no-trace
+# endif
CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
diff --git a/eval.scm b/eval.scm
index e481749..c02a846 100644
--- a/eval.scm
+++ b/eval.scm
@@ -32,7 +32,6 @@
(not inline ##sys#repl-read-hook ##sys#repl-print-hook
##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
##sys#syntax-error-hook))
-
#>
#ifndef C_INSTALL_EGG_HOME
# define C_INSTALL_EGG_HOME "."
@@ -50,6 +49,7 @@
<#
(include "common-declarations.scm")
+(include "ses.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -193,37 +193,30 @@
(define ##sys#unbound-in-eval #f)
(define ##sys#eval-debug-level (make-parameter 1))
+(define (se-rename-lookup var0 e se)
+ (define (posq x lst)
+ (let loop ([lst lst] [i 0])
+ (cond [(null? lst) #f]
+ [(eq? x (car lst)) i]
+ [else (loop (cdr lst) (add1 i))] ) ) )
+ (let ((var (se-rename var0 se)))
+ ;; (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map (lambda (x) (car x)) se)))
+ ;; (print `(LOOKUP/EVAL: ,var0 ,var ,e ,(se-identifiers se)))
+ (let loop ((envs e) (ei 0))
+ (cond ((null? envs) (values #f var))
+ ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
+ (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
+
(define ##sys#compile-to-closure
(let ([write write]
[reverse reverse]
[with-input-from-file with-input-from-file]
[unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
- [display display] )
+ [display display]
+ [rename se-rename]
+ [lookup se-rename-lookup])
(lambda (exp env se #!optional cntr evalenv static)
-
- (define (find-id id se) ; ignores macro bindings
- (cond ((null? se) #f)
- ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
- (else (find-id id (cdr se)))))
-
- (define (rename var se)
- (cond ((find-id var se))
- ((##sys#get var '##core#macro-alias))
- (else var)))
-
- (define (lookup var0 e se)
- (let ((var (rename var0 se)))
- (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map (lambda (x) (car x)) se)))
- (let loop ((envs e) (ei 0))
- (cond ((null? envs) (values #f var))
- ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
- (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
-
- (define (posq x lst)
- (let loop ((lst lst) (i 0))
- (cond ((null? lst) #f)
- ((eq? x (##sys#slot lst 0)) i)
- (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
+ (assert (valid-se? se))
(define (emit-trace-info tf info cntr e v)
(when tf
@@ -245,12 +238,13 @@
(##sys#eval-decorator p ll h cntr) )
(define (compile x e h tf cntr se)
+ (assert (real-se? se))
(cond ((keyword? x) (lambda v x))
((symbol? x)
(receive (i j) (lookup x e se)
(cond ((not i)
(let ((var (cond ((not (symbol? j)) x) ; syntax?
- ((not (assq x se))
+ ((not (se-assq x se))
(and (not static)
(##sys#alias-global-hook j #f cntr)))
(else (or (##sys#get j '##core#primitive) j)))))
@@ -369,11 +363,11 @@
(let ((val (compile (caddr x) e var tf cntr se)))
(cond [(not i)
(when ##sys#notices-enabled
- (and-let* ((a (assq var (##sys#current-environment)))
+ (and-let* ((a (se-assq var (##sys#current-environment)))
((symbol? (cdr a))))
(##sys#notice "assignment to imported value binding" var)))
(let ((var
- (if (not (assq x se)) ;XXX this looks wrong
+ (if (not (se-assq x se)) ;XXX this looks wrong
(and (not static)
(##sys#alias-global-hook j #t cntr))
(or (##sys#get j '##core#primitive) j))))
@@ -562,34 +556,36 @@
info h cntr) ) ) ] ) ) ) ) ) ]
((##core#let-syntax)
- (let ((se2 (append
- (map (lambda (b)
- (list
- (car b)
- se
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (car b))))
- (cadr x) )
+ (let ((se2 (se-append
+ (make-se
+ (map (lambda (b)
+ (list
+ (car b)
+ se
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (car b))))
+ (cadr x) ))
se) ) )
(compile
(##sys#canonicalize-body (cddr x) se2 #f)
e #f tf cntr se2)))
((##core#letrec-syntax)
- (let* ((ms (map (lambda (b)
- (list
- (car b)
- #f
- (##sys#ensure-transformer
- (##sys#eval/meta (cadr b))
- (car b))))
- (cadr x) ) )
- (se2 (append ms se)) )
- (for-each
+ (let* ((ms (make-se
+ (map (lambda (b)
+ (list
+ (car b)
+ #f
+ (##sys#ensure-transformer
+ (##sys#eval/meta (cadr b))
+ (car b))))
+ (cadr x) )) )
+ (se2 (se-append ms se)) )
+ (se-for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
- ms)
+ ms)
(compile
(##sys#canonicalize-body (cddr x) se2 #f)
e #f tf cntr se2)))
@@ -598,7 +594,7 @@
(let* ((var (cadr x))
(body (caddr x))
(name (rename var se)))
- (when (and static (not (assq var se)))
+ (when (and static (not (se-assq var se)))
(##sys#error 'eval "environment is not mutable" evalenv var))
(##sys#register-syntax-export
name (##sys#current-module)
@@ -654,9 +650,9 @@
(##sys#syntax-error-hook 'module "modules may not be nested" name))
(parameterize ((##sys#current-module
(##sys#register-module name exports))
- (##sys#current-environment '())
+ (##sys#current-environment (make-se))
(##sys#macro-environment
- ##sys#initial-macro-environment)
+ (se-derive-new ##sys#initial-macro-environment))
(##sys#module-alias-environment
(##sys#module-alias-environment)))
(##sys#with-property-restore
@@ -860,7 +856,7 @@
(##sys#check-structure env 'environment 'eval)
(let ((se2 (##sys#slot env 2)))
((if se2 ; not interaction-environment?
- (parameterize ((##sys#macro-environment '()))
+ (parameterize ((##sys#macro-environment (make-se)))
(##sys#compile-to-closure x '() se2 #f env (##sys#slot env 3)))
(##sys#compile-to-closure x '() se #f env #f))
'() ) ) )
@@ -1424,24 +1420,19 @@
(r4n (module-environment 'r4rs-null 'null-environment/4))
(r5n (module-environment 'r5rs-null 'null-environment/5)))
(define (strip se)
- (foldr
- (lambda (s r)
- (if (memq (car s)
- '(import
- require-extension
- require-extension-for-syntax
- require-library
- begin-for-syntax
- export
- module
- cond-expand
- syntax
- reexport
- import-for-syntax))
- r
- (cons s r)))
- '()
- se))
+ (let ([ids '(import
+ require-extension
+ require-extension-for-syntax
+ require-library
+ begin-for-syntax
+ export
+ module
+ cond-expand
+ syntax
+ reexport
+ import-for-syntax)])
+ (receive (_missing se2) (se-derive-except ids se)
+ se2)))
;; Strip non-std syntax from SEs
(##sys#setslot r4s 2 (strip (##sys#slot r4s 2)))
(##sys#setslot r4n 2 (strip (##sys#slot r4n 2)))
diff --git a/expand.scm b/expand.scm
index 9e73e09..3c677a4 100644
--- a/expand.scm
+++ b/expand.scm
@@ -40,6 +40,7 @@
##sys#toplevel-definition-hook))
(include "common-declarations.scm")
+(include "ses.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -70,17 +71,12 @@
;;; Syntactic environments
-(define ##sys#current-environment (make-parameter '()))
-(define ##sys#current-meta-environment (make-parameter '()))
+(define ##sys#current-environment (make-parameter (make-se)))
+(define ##sys#current-meta-environment (make-parameter (make-se)))
;;XXX should this be in eval.scm?
(define ##sys#active-eval-environment (make-parameter ##sys#current-environment))
-(define (lookup id se)
- (cond ((##core#inline "C_u_i_assq" id se) => cdr)
- ((getp id '##core#macro-alias))
- (else #f)))
-
(define (macro-alias var se)
(if (or (##sys#qualified-symbol? var)
(let* ((str (##sys#slot var 1))
@@ -130,41 +126,41 @@
(define (##sys#extend-se se vars #!optional (aliases (map gensym vars)))
(for-each
(lambda (alias sym)
+ ;; (print "extend-se " sym " -> " alias)
(let ((original-real-name (getp sym '##core#real-name)))
(putp alias '##core#real-name (or original-real-name sym))))
aliases vars)
- (append (map (lambda (x y) (cons x y)) vars aliases) se)) ; inline cons
+ (se-append (make-se (map (lambda (x y) (cons x y)) vars aliases)) se)) ; inline cons
;;; resolve symbol to global name
(define (##sys#globalize sym se)
+ (assert (real-se? se))
(let loop1 ((sym sym))
(cond ((not (symbol? sym)) sym)
((getp sym '##core#macro-alias) =>
(lambda (a) (if (symbol? a) (loop1 a) sym)))
(else
- (let loop ((se se)) ; ignores syntax bindings
- (cond ((null? se)
- (##sys#alias-global-hook sym #t #f)) ;XXX could hint at decl (3rd arg)
- ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
- (else (loop (cdr se)))))))))
+ (find-id/alias sym se)))))
;;; Macro handling
-(define ##sys#macro-environment (make-parameter '()))
-(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
-(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
+(define ##sys#macro-environment (make-parameter (make-se)))
+(define ##sys#chicken-macro-environment (make-se)) ; used later in chicken.import.scm
+(define ##sys#chicken-ffi-macro-environment (make-se)) ; used later in foreign.import.scm
(define (##sys#ensure-transformer t #!optional loc)
(cond ((procedure? t) (##sys#slot (##sys#er-transformer t) 1)) ; DEPRECATED
((##sys#structure? t 'transformer) (##sys#slot t 1))
(else (##sys#error loc "expected syntax-transformer, but got" t))))
-(define (##sys#extend-macro-environment name se transformer)
+(define (##sys#extend-macro-environment name se* transformer)
(let ((me (##sys#macro-environment))
+ (se (if (real-se? se*) se* (make-se se*)))
(handler (##sys#ensure-transformer transformer name)))
+ (assert (valid-se? se))
(cond ((lookup name me) =>
(lambda (a)
(set-car! a se)
@@ -173,7 +169,7 @@
(else
(let ((data (list se handler)))
(##sys#macro-environment
- (cons (cons name data) me))
+ (se-cons name data me))
data)))))
(define (##sys#copy-macro old new)
@@ -201,7 +197,9 @@
;; The basic macro-expander
(define (##sys#expand-0 exp dse cs?)
- (define (call-handler name handler exp se cs)
+ (assert (real-se? dse))
+ (assert (real-se? (##sys#macro-environment)))
+ (define (call-handler name handler exp se* cs)
(dd "invoking macro: " name)
(dd `(STATIC-SE: ,@(map-se se)))
(handle-exceptions ex
@@ -231,20 +229,26 @@
(cdr r) ) )
(copy r) ) ) ) ) )
ex) )
- (let ((exp2
- (if cs
- ;; compiler-syntax may "fall through"
- (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
- (handler exp se dse))
- (handler exp se dse))) )
- (when (and (not cs) (eq? exp exp2))
- (##sys#syntax-error-hook
- (string-append
- "syntax transformer for `" (symbol->string name)
- "' returns original form, which would result in endless expansion")
- exp))
- (dx `(,name ~~> ,exp2))
- exp2)))
+ ;; (print "call-handler " name " " handler "real: " (real-se? se*))
+ (let* ([se (if (real-se? se*) se* (make-se se*))]
+ [_ (assert (valid-se? se))]
+ (exp2
+ (if cs
+ ;; compiler-syntax may "fall through"
+ (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
+ (handler exp se dse))
+ (begin
+ (assert (real-se? se))
+ (assert (real-se? dse))
+ (handler exp se dse)))) )
+ (when (and (not cs) (eq? exp exp2))
+ (##sys#syntax-error-hook
+ (string-append
+ "syntax transformer for `" (symbol->string name)
+ "' returns original form, which would result in endless expansion")
+ exp))
+ (dx `(,name ~~> ,exp2))
+ exp2)))
(define (expand head exp mdef)
(dd `(EXPAND:
,head
@@ -289,6 +293,7 @@
[else (values exp #f)] ) ) ]
((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
(lambda (cs)
+ (assert (not (mangled-se? (cdr cs))))
(let ((result (call-handler head (car cs) exp (cdr cs) #t)))
(cond ((eq? result exp) (expand head exp head2))
(else
@@ -307,6 +312,7 @@
;;; User-level macroexpansion
(define (expand exp #!optional (se (##sys#current-environment)) cs?)
+ (assert (real-se? se))
(let loop ((exp exp))
(let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
(if m
@@ -448,17 +454,30 @@
(##sys#decompose-lambda-list
formals
(lambda (vars argc rest)
- (let ((aliases (if (symbol? formals) '() (map gensym formals)))
- (rest-alias (if (not rest) '() (gensym rest))))
- `(##sys#call-with-values
- (##core#lambda () ,expr)
- (##core#lambda
- ,(append aliases rest-alias)
- ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
- ,@(cond
- ((null? formals) '((##core#undefined)))
- ((null? rest-alias) '())
- (else `((##core#set! ,rest ,rest-alias))))))))))
+ (let* ((aliases (if (symbol? formals) '() (map gensym vars)))
+ (rest-alias (cond [(symbol? formals) (gensym formals)]
+ [rest (car (reverse aliases))]
+ [else '()])))
+ ;; (print "here " "formals: " formals " aliases: " aliases " rest " rest-alias (null? rest-alias))
+ (let ([r `(##sys#call-with-values
+ (##core#lambda () ,expr)
+ (##core#lambda
+ ,(cond
+ [(symbol? formals) rest-alias]
+ [(and rest (null? (cdr vars))) rest-alias]
+ [(null? aliases) aliases]
+ [rest (let lp ([vs aliases])
+ (if (null? (cdr vs))
+ (car vs)
+ (cons (car vs) (lp (cdr vs)))))]
+ [else aliases])
+ ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)
+ ,@(cond
+ ((null? formals) '((##core#undefined)))
+ ((null? rest-alias) '())
+ (else `((##core#set! ,rest ,rest-alias))))))])
+ ;; (print r)
+ r)))))
;;; Expansion of bodies (and internal definitions)
;
@@ -470,6 +489,7 @@
(define ##sys#canonicalize-body
(lambda (body #!optional (se (##sys#current-environment)) cs?)
+ (assert (real-se? se))
(define (comp s id)
(let ((f (lookup id se)))
(or (eq? s f)
@@ -801,33 +821,35 @@
(##sys#make-structure
'transformer
(lambda (form se dse)
- (let ((renv '())) ; keep rename-environment for this expansion
- (assert (list? se) "not a list" se) ;XXX remove later
+ (let ((renv (make-se))) ; keep rename-environment for this expansion
+ (assert (real-se? se)) ;XXX remove later
(define (rename sym)
+ (assert (real-se? se)) ;XXX remove later
+ (assert (real-se? renv))
(cond ((pair? sym)
(cons (rename (car sym)) (rename (cdr sym))))
((vector? sym)
(list->vector (rename (vector->list sym))))
((not (symbol? sym)) sym)
- ((assq sym renv) =>
- (lambda (a)
+ ((se-assq sym renv) =>
+ (lambda (a)
(dd `(RENAME/RENV: ,sym --> ,(cdr a)))
(cdr a)))
- ((assq sym se) =>
+ ((se-assq sym se) =>
(lambda (a)
(cond ((symbol? a)
(dd `(RENAME/SE: ,sym --> ,a))
- (set! renv (cons (cons sym a) renv))
+ (set! renv (se-cons sym a renv))
a)
(else
(let ((a2 (macro-alias sym se)))
(dd `(RENAME/SE/MACRO: ,sym --> ,a2))
- (set! renv (cons (cons sym a2) renv))
+ (set! renv (se-cons sym a2 renv))
a2)))))
(else
(let ((a (macro-alias sym se)))
(dd `(RENAME: ,sym --> ,a))
- (set! renv (cons (cons sym a) renv))
+ (set! renv (se-cons sym a renv))
a))))
(define (compare s1 s2)
(let ((result
@@ -853,11 +875,11 @@
(cond ((symbol? ss2)
(eq? (or (getp ss1 '##core#primitive) ss1)
(or (getp ss2 '##core#primitive) ss2)))
- ((assq ss1 (##sys#macro-environment)) =>
+ ((se-assq ss1 (##sys#macro-environment)) =>
(lambda (a) (eq? (cdr a) ss2)))
(else #f) ) )
((symbol? ss2)
- (cond ((assq ss2 (##sys#macro-environment)) =>
+ (cond ((se-assq ss2 (##sys#macro-environment)) =>
(lambda (a) (eq? ss1 (cdr a))))
(else #f)))
(else (eq? ss1 ss2)))))
@@ -872,11 +894,7 @@
r)
")")
r))
- (define (assq-reverse s l)
- (cond
- ((null? l) #f)
- ((eq? (cdar l) s) (car l))
- (else (assq-reverse s (cdr l)))))
+
(define (mirror-rename sym)
(cond ((pair? sym)
(cons (mirror-rename (car sym)) (mirror-rename (cdr sym))))
@@ -885,7 +903,7 @@
((not (symbol? sym)) sym)
(else ; Code stolen from ##sys#strip-syntax
(let ((renamed (lookup sym se) ) )
- (cond ((assq-reverse sym renv) =>
+ (cond ((se-assq-reverse sym renv) =>
(lambda (a)
(dd "REVERSING RENAME: " sym " --> " (car a)) (car a)))
((not renamed)
@@ -941,7 +959,7 @@
#f #t 'reexport) ) )
;; contains only "import[-for-syntax]" and "reexport"
-(define ##sys#initial-macro-environment (##sys#macro-environment))
+(define ##sys#initial-macro-environment (se-derive-new (##sys#macro-environment)))
(##sys#extend-macro-environment
'lambda
@@ -1021,7 +1039,7 @@
(##sys#check-syntax 'define-syntax head 'symbol)
(##sys#check-syntax 'define-syntax body '#(_ 1))
(let ((name (or (getp head '##core#macro-alias) head)))
- (##sys#register-export name (##sys#current-module)))
+ (##sys#register-export name (##sys#current-module)))
(when (c (r 'define-syntax) head)
(##sys#defjam-error form))
`(##core#define-syntax ,head ,(car body)))
@@ -1527,22 +1545,19 @@
;;; the base macro environment ("scheme", essentially)
(define (##sys#macro-subset me0 #!optional parent-env)
- (let ((se (let loop ((me (##sys#macro-environment)))
- (if (or (null? me) (eq? me me0))
- '()
- (cons (car me) (loop (cdr me)))))))
+ (let ((se (se-not-tail me0 (##sys#macro-environment))))
(##sys#fixup-macro-environment se parent-env)))
(define (##sys#fixup-macro-environment se #!optional parent-env)
- (let ((se2 (if parent-env (##sys#append se parent-env) se)))
- (for-each ; fixup se
+ (let ((se2 (if parent-env (se-append se parent-env) se)))
+ (se-for-each ; fixup se
(lambda (sdef)
(when (pair? (cdr sdef))
(set-car!
(cdr sdef)
(if (null? (cadr sdef))
se2
- (##sys#append (cadr sdef) se2)))))
+ (se-append (cadr sdef) se2)))))
se)
se))
diff --git a/modules.scm b/modules.scm
index a346028..bdebbc1 100644
--- a/modules.scm
+++ b/modules.scm
@@ -29,13 +29,14 @@
(disable-interrupts)
(fixnum)
(hide lookup merge-se module-indirect-exports)
- (not inline ##sys#alias-global-hook))
-
+ (not inline ##sys#alias-global-hook merge-se))
+
(use (only srfi-69 make-hash-table hash-table-exists?))
(include "common-declarations.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
+;; (define d (lambda x (apply print (map ->string x))))
(define-alias dd d)
(define-alias dm d)
@@ -57,16 +58,15 @@
;;; Support definitions
;; duoplicates code in the hope of being inlined
-(define (lookup id se)
- (cond ((##core#inline "C_u_i_assq" id se) => cdr)
- ((getp id '##core#macro-alias))
- (else #f)))
+
+(include "ses.scm")
#+debugbuild
(define (map-se se)
- (map (lambda (a)
- (cons (car a) (if (symbol? (cdr a)) (cdr a) ')))
- se))
+ (se->list
+ (se-map (lambda (a)
+ (cons (car a) (if (symbol? (cdr a)) (cdr a) ')))
+ se)))
;;; low-level module support
@@ -168,11 +168,11 @@
(sexps '()))
(for-each
(lambda (exp)
- (cond ((assq exp me) =>
+ (cond ((se-assq exp me) =>
(lambda (a)
(set! sexps (cons a sexps))))))
exps)
- (set-module-sexports! mod (append sexps (module-sexports mod)))
+ (set-module-sexports! mod (se-append (make-se sexps) (module-sexports mod)))
(set-module-exist-list! mod (append el exps)))
(set-module-export-list! mod (append xl exps)))))
@@ -183,9 +183,9 @@
(set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
(define (check-for-redef sym env senv)
- (and-let* ((a (assq sym env)))
+ (and-let* ((a (se-assq sym env)))
(##sys#warn "redefinition of imported value binding" sym) )
- (and-let* ((a (assq sym senv)))
+ (and-let* ((a (se-assq sym senv)))
(##sys#warn "redefinition of imported syntax binding" sym)))
(define (##sys#register-export sym mod)
@@ -239,12 +239,12 @@
(cons (cons sym (if where (list where) '())) ul)))))))
(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
- (let ((mod (make-module name explist vexports sexports '())))
+ (let ((mod (make-module name explist (make-se vexports) (make-se sexports) (make-se))))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod) )
(define (##sys#mark-imported-symbols se)
- (for-each
+ (se-for-each
(lambda (imp)
(when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
(dm `(MARKING: ,(cdr imp)))
@@ -273,7 +273,7 @@
(else
(let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
(cond ((null? iexports) (loop (cdr exports)))
- ((assq (car iexports) (##sys#macro-environment))
+ ((se-assq (car iexports) (##sys#macro-environment))
(warn "indirect export of syntax binding" (car iexports))
(loop2 (cdr iexports)))
((assq (car iexports) dlist) => ; defined in current module?
@@ -283,7 +283,7 @@
(car iexports)
(or (cdr a) (##sys#module-rename (car iexports) mname)))
(loop2 (cdr iexports)))))
- ((assq (car iexports) (##sys#current-environment)) =>
+ ((se-assq (car iexports) (##sys#current-environment)) =>
(lambda (a) ; imported in current env.
(cond ((symbol? (cdr a)) ; not syntax
(cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
@@ -294,9 +294,6 @@
(warn "indirect export of unknown binding" (car iexports))
(loop2 (cdr iexports)))))))))))
-(define (merge-se . ses) ; later occurrences take precedence to earlier ones
- (apply append (reverse ses)))
-
(define (##sys#compiled-module-registration mod)
(let ((dlist (module-defined-list mod))
(mname (module-name mod))
@@ -308,78 +305,89 @@
,@(##sys#fast-reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
(##sys#register-compiled-module
',(module-name mod)
+ ',(se->list
+ (se-map (lambda (ie)
+ (if (symbol? (cdr ie))
+ `(,(car ie) . ,(cdr ie))
+ `(list ,(car ie) () ,(cdr ie))))
+ (module-iexports mod)))
+ ',(se->list (module-vexports mod))
(list
- ,@(map (lambda (ie)
- (if (symbol? (cdr ie))
- `'(,(car ie) . ,(cdr ie))
- `(list ',(car ie) '() ,(cdr ie))))
- (module-iexports mod)))
- ',(module-vexports mod)
- (list
,@(map (lambda (sexport)
(let* ((name (car sexport))
(a (assq name dlist)))
- (cond ((pair? a)
+ (cond ((pair? a)
`(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
(else
(dm "re-exported syntax" name mname)
`',name))))
- sexports))
- (list
+ (se-entries sexports)))
+ (list
,@(if (null? sexports)
'() ; no syntax exported - no more info needed
(let loop ((sd (module-defined-syntax-list mod)))
(cond ((null? sd) '())
- ((assq (caar sd) sexports) (loop (cdr sd)))
+ ((se-assq (caar sd) sexports) (loop (cdr sd)))
(else
(let ((name (caar sd)))
(cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
(loop (cdr sd)))))))))))))
-(define (##sys#register-compiled-module name iexports vexports sexports #!optional
+(define (##sys#register-compiled-module name iexports vexports* sexports #!optional
(sdefs '()))
(define (find-reexport name)
- (let ((a (assq name (##sys#macro-environment))))
+ (let ((a (se-assq name (##sys#macro-environment))))
(if (and a (pair? (cdr a)))
a
(##sys#error
'import "cannot find implementation of re-exported syntax"
name))))
(let* ((sexps
- (map (lambda (se)
- (if (symbol? se)
- (find-reexport se)
- (list (car se) #f (##sys#ensure-transformer (cdr se) (car se)))))
- sexports))
- (iexps
- (map (lambda (ie)
- (if (pair? (cdr ie))
- (list (car ie) (cadr ie) (##sys#ensure-transformer (caddr ie) (car ie)))
- ie))
- iexports))
+ (make-se
+ (map (lambda (se)
+ (if (symbol? se)
+ (find-reexport se)
+ (list (car se) #f (##sys#ensure-transformer (cdr se) (car se)))))
+ sexports)))
+ (iexps
+ (make-se
+ (map (lambda (ie)
+ (if (pair? (cdr ie))
+ (list (car ie) (cadr ie) (##sys#ensure-transformer (caddr ie) (car ie)))
+ ie))
+ iexports)))
(nexps
- (map (lambda (ne)
- (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
- sdefs))
+ (make-se
+ (map (lambda (ne)
+ (list (car ne) #f (##sys#ensure-transformer (cdr ne) (car ne))))
+ sdefs)))
+ (vexports (make-se vexports*))
(mod (make-module name '() vexports sexps iexps))
+ (_ (assert (valid-se? (##sys#macro-environment))))
+ (_ (assert (valid-se? (##sys#current-environment))))
+ (_ (assert (valid-se? iexps)))
+ (_ (assert (valid-se? vexports)))
+ (_ (assert (valid-se? sexps)))
+ (_ (assert (valid-se? nexps)))
(senv (merge-se
(##sys#macro-environment)
(##sys#current-environment)
iexps vexports sexps nexps)))
(##sys#mark-imported-symbols iexps)
- (for-each
- (lambda (sexp)
- (set-car! (cdr sexp) (merge-se (or (cadr sexp) '()) senv)))
- sexps)
- (for-each
- (lambda (iexp)
- (when (pair? (cdr iexp))
- (set-car! (cdr iexp) (merge-se (or (cadr iexp) '()) senv))))
- iexps)
- (for-each
- (lambda (nexp)
- (set-car! (cdr nexp) (merge-se (or (cadr nexp) '()) senv)))
- nexps)
+ (let ([fix (lambda (exps)
+ (se-for-each
+ (lambda (exp)
+ (when (pair? (cdr exp))
+ (set-car! (cdr exp)
+ (cond [(cadr exp) =>
+ (lambda (se2)
+ (merge-se (if (real-se? se2) se2 (make-se se2))
+ senv))]
+ [senv]))))
+ exps))])
+ (fix sexps)
+ (fix iexps)
+ (fix nexps))
(set-module-saved-environments!
mod
(cons (merge-se (##sys#current-environment) vexports sexps)
@@ -394,24 +402,29 @@
(putp palias '##core#primitive sym)
palias))
-(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
- (let* ((me (##sys#macro-environment))
+(define (##sys#register-primitive-module name vexports #!optional (sexports* (make-se)))
+ (let* ((sexports (if (real-se? sexports*) sexports* (make-se sexports*)))
+ (me (##sys#macro-environment))
(mod (make-module
name '()
- (map (lambda (ve)
- (if (symbol? ve)
- (cons ve (##sys#primitive-alias ve))
- ve))
- vexports)
- (map (lambda (se)
- (if (symbol? se)
- (or (assq se me)
- (##sys#error
- "unknown syntax referenced while registering module"
- se name))
- se))
- sexports)
- '())))
+ (make-se
+ (map (lambda (ve)
+ (if (symbol? ve)
+ (cons ve (##sys#primitive-alias ve))
+ ve))
+ vexports))
+ (se-map (lambda (se)
+ (if (symbol? se)
+ (or (se-assq se me)
+ (##sys#error
+ "unknown syntax referenced while registering module"
+ se name))
+ se))
+ sexports)
+ (make-se))))
+ (assert (real-se? (##sys#current-environment)) "not real-se (##sys#current-environment)")
+ (assert (real-se? (module-vexports mod)) "2")
+ (assert (real-se? (module-sexports mod)) "3")
(set-module-saved-environments!
mod
(cons (merge-se (##sys#current-environment)
@@ -441,45 +454,51 @@
(dlist (module-defined-list mod))
(elist (module-exist-list mod))
(missing #f)
- (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
- (module-defined-syntax-list mod)))
+ (sdlist (make-se
+ (map (lambda (sym) (se-assq (car sym) (##sys#macro-environment)))
+ (module-defined-syntax-list mod))))
(sexports
(if (eq? #t explist)
(merge-se (module-sexports mod) sdlist)
- (let loop ((me (##sys#macro-environment)))
- (cond ((null? me) '())
- ((##sys#find-export (caar me) mod #f)
- (cons (car me) (loop (cdr me))))
- (else (loop (cdr me)))))))
+ ;; (let loop ((me (##sys#macro-environment)))
+ ;; (cond ((null? me) '())
+ ;; ((##sys#find-export (caar me) mod #f)
+ ;; (cons (car me) (loop (cdr me))))
+ ;; (else (loop (cdr me)))))
+ (se-fold (lambda (e l) (if (##sys#find-export (car e) mod #f)
+ (cons e l)
+ l))
+ (##sys#macro-environment))))
(vexports
- (let loop ((xl (if (eq? #t explist) elist explist)))
- (if (null? xl)
- '()
- (let* ((h (car xl))
- (id (if (symbol? h) h (car h))))
- (if (assq id sexports)
- (loop (cdr xl))
- (cons
+ (make-se
+ (let loop ((xl (if (eq? #t explist) elist explist)))
+ (if (null? xl)
+ '()
+ (let* ((h (car xl))
+ (id (if (symbol? h) h (car h))))
+ (if (se-assq id sexports)
+ (loop (cdr xl))
(cons
- id
- (let ((def (assq id dlist)))
- (if (and def (symbol? (cdr def)))
- (cdr def)
- (let ((a (assq id (##sys#current-environment))))
- (cond ((and a (symbol? (cdr a)))
- (dm "reexporting: " id " -> " (cdr a))
- (cdr a))
- ((not def)
- (set! missing #t)
- (##sys#warn
- (string-append
- "exported identifier of module `"
- (symbol->string name)
- "' has not been defined")
- id)
- #f)
- (else (##sys#module-rename id name)))))))
- (loop (cdr xl)))))))))
+ (cons
+ id
+ (let ((def (assq id dlist)))
+ (if (and def (symbol? (cdr def)))
+ (cdr def)
+ (let ((a (se-assq id (##sys#current-environment))))
+ (cond ((and a (symbol? (cdr a)))
+ (dm "reexporting: " id " -> " (cdr a))
+ (cdr a))
+ ((not def)
+ (set! missing #t)
+ (##sys#warn
+ (string-append
+ "exported identifier of module `"
+ (symbol->string name)
+ "' has not been defined")
+ id)
+ #f)
+ (else (##sys#module-rename id name)))))))
+ (loop (cdr xl))))))))))
(for-each
(lambda (u)
(let* ((where (cdr u))
@@ -515,17 +534,24 @@
(when missing
(##sys#error "module unresolved" name))
(let* ((iexports
- (map (lambda (exp)
- (cond ((symbol? (cdr exp)) exp)
- ((assq (car exp) (##sys#macro-environment)))
- (else (##sys#error "(internal) indirect export not found" (car exp)))) )
- (module-indirect-exports mod)))
+ (make-se
+ (map (lambda (exp)
+ (cond ((symbol? (cdr exp)) exp)
+ ((se-assq (car exp) (##sys#macro-environment)))
+ (else (##sys#error "(internal) indirect export not found" (car exp)))) )
+ (module-indirect-exports mod))))
+ (_ (assert (real-se? (##sys#macro-environment))))
+ (_ (assert (real-se? (##sys#current-environment))))
+ (_ (assert (real-se? iexports)))
+ (_ (assert (real-se? vexports)))
+ (_ (assert (real-se? sexports)))
+ (_ (assert (real-se? sdlist)))
(new-se (merge-se
(##sys#macro-environment)
(##sys#current-environment)
iexports vexports sexports sdlist)))
(##sys#mark-imported-symbols iexports)
- (for-each
+ (se-for-each
(lambda (m)
(let ((se (merge-se (cadr m) new-se))) ;XXX needed?
(dm `(FIXUP: ,(car m) ,@(map-se se)))
@@ -540,6 +566,8 @@
(SEXPORTS: ,@(map-se sexports))))
(set-module-vexports! mod vexports)
(set-module-sexports! mod sexports)
+ (assert (real-se? iexports))
+ (assert (real-se? (module-iexports mod)))
(set-module-iexports!
mod
(merge-se (module-iexports mod) iexports)) ; "reexport" may already have added some
@@ -561,7 +589,7 @@
(string-append (symbol->string mname) ".import")
#t)))
(cond (il (parameterize ((##sys#current-module #f)
- (##sys#current-environment '())
+ (##sys#current-environment (make-se))
(##sys#current-meta-environment
(##sys#current-meta-environment))
(##sys#macro-environment
@@ -582,7 +610,7 @@
(%prefix (r 'prefix))
(%srfi (r 'srfi)))
(define (resolve sym)
- (or (lookup sym '()) sym)) ;XXX really empty se?
+ (or (lookup sym (make-se)) sym)) ;XXX really empty se?
(define (warn msg mod id)
(##sys#warn (sprintf msg mod id)))
(define (tostr x)
@@ -597,6 +625,9 @@
(sexp (module-sexports mod))
(iexp (module-iexports mod))
(name (module-name mod)))
+ (assert (valid-se? vexp))
+ (assert (valid-se? sexp))
+ (assert (valid-se? iexp))
(values name name vexp sexp iexp)))
(define (import-spec spec)
(cond ((symbol? spec) (import-name spec))
@@ -607,85 +638,52 @@
(##sys#intern-symbol
(##sys#string-append "srfi-" (##sys#number->string (cadr spec))))))
(else
- (let ((head (car spec))
- (imports (cddr spec)))
+ (let ([head (car spec)]
+ [imports (cddr spec)])
(let-values (((name form impv imps impi) (import-spec (cadr spec))))
- (cond ((c %only head)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve imports)))
- (let loop ((ids ids) (v '()) (s '()) (missing '()))
- (cond ((null? ids)
- (for-each
- (lambda (id)
- (warn "imported identifier doesn't exist in module ~s: ~s" name id))
- missing)
- (values name `(,head ,form ,@imports) v s impi))
- ((assq (car ids) impv) =>
- (lambda (a)
- (loop (cdr ids) (cons a v) s missing)))
- ((assq (car ids) imps) =>
- (lambda (a)
- (loop (cdr ids) v (cons a s) missing)))
- (else
- (loop (cdr ids) v s (cons (car ids) missing)))))))
- ((c %except head)
- (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
- (let ((ids (map resolve imports)))
- (let loop ((impv impv) (v '()) (ids imports))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()) (ids ids))
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (warn "excluded identifier doesn't exist in module ~s: ~s" name id))
- ids)
- (values name `(,head ,form ,@imports) v s impi))
- ((memq (caar imps) ids) =>
- (lambda (id)
- (loop (cdr imps) s (##sys#delq (car id) ids))))
- (else
- (loop (cdr imps) (cons (car imps) s) ids)))))
- ((memq (caar impv) ids) =>
- (lambda (id)
- (loop (cdr impv) v (##sys#delq (car id) ids))))
- (else
- (loop (cdr impv) (cons (car impv) v) ids))))))
- ((c %rename head)
- (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
- (let loop ((impv impv) (v '()) (ids imports))
- (cond ((null? impv)
- (let loop ((imps imps) (s '()) (ids ids))
- (cond ((null? imps)
- (for-each
- (lambda (id)
- (warn "renamed identifier doesn't exist in module ~s: ~s" name id))
- (map car ids))
- (values name `(,head ,form ,@imports) v s impi))
- ((assq (caar imps) ids) =>
- (lambda (a)
- (loop (cdr imps)
- (cons (cons (cadr a) (cdar imps)) s)
- (##sys#delq a ids))))
- (else
- (loop (cdr imps) (cons (car imps) s) ids)))))
- ((assq (caar impv) ids) =>
- (lambda (a)
- (loop (cdr impv)
- (cons (cons (cadr a) (cdar impv)) v)
- (##sys#delq a ids))))
- (else
- (loop (cdr impv) (cons (car impv) v) ids)))))
- ((c %prefix head)
- (##sys#check-syntax loc spec '(_ _ _))
- (let* ([pref (caddr spec)]
- [pref-str (tostr pref)])
- (define (ren imp)
- (cons
- (##sys#string->symbol
- (##sys#string-append pref-str (##sys#symbol->string (car imp))))
- (cdr imp) ) )
- (values name `(,head ,form ,pref) (map ren impv) (map ren imps) impi)))
- (else (##sys#syntax-error-hook loc "invalid import specification" spec))))))))
+ (assert (valid-se? impv))
+ (assert (valid-se? imps))
+ (assert (valid-se? impi))
+ (let ([imp-form `(,head ,form ,@imports)])
+ ;; (print "IMPORT" imp-form " v: " (se-size impv) " s: " (se-size imps))
+ (cond ((c %only head)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let lp ([ids (map resolve imports)]
+ [vs '()]
+ [ss '()])
+ (cond
+ [(null? ids) (values name imp-form (make-se vs) (make-se ss) impi)]
+ [(se-assq (car ids) impv) => (lambda (e) (lp (cdr ids) (cons e vs) ss))]
+ [(se-assq (car ids) imps) => (lambda (e) (lp (cdr ids) vs (cons e ss)))]
+ [else (warn "imported identifier doesn't exist in module ~s: ~s"
+ name (car ids))
+ (lp (cdr ids) vs ss)])))
+ ((c %except head)
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve imports)))
+ (receive (missing v s) (se-derive-except ids impv imps)
+ (for-each
+ (lambda (id)
+ (warn "excluded identifier doesn't exist in module ~s: ~s" name id))
+ missing)
+ (values name imp-form v s impi))))
+ ((c %rename head)
+ (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
+ (receive (missing v s) (se-derive-rename imports impv imps)
+ (for-each
+ (lambda (id)
+ (warn "renamed identifier doesn't exist in module ~s: ~s" name id))
+ missing)
+ (values name imp-form v s impi)))
+ ((c %prefix head)
+ (##sys#check-syntax loc spec '(_ _ _))
+ (let* ([pref (caddr spec)]
+ [pref-str (tostr pref)])
+ (values name `(,head ,form ,pref)
+ (se-derive-prefix pref-str impv)
+ (se-derive-prefix pref-str imps)
+ impi)))
+ (else (##sys#syntax-error-hook loc "invalid import specification" spec)))))))))
(##sys#check-syntax loc x '(_ . #(_ 1)))
(let ((cm (##sys#current-module)))
(for-each
@@ -699,21 +697,21 @@
(set-module-import-forms!
cm
(append (module-import-forms cm) (list form)))))
- (dd `(IMPORT: ,loc))
+ (dd `(IMPORT: ,x))
(dd `(V: ,(if cm (module-name cm) ') ,(map-se vsv)))
(dd `(S: ,(if cm (module-name cm) ') ,(map-se vss)))
(##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
- (for-each
+ (se-for-each
(lambda (imp)
(and-let* ((id (car imp))
- (a (assq id (import-env)))
+ (a (se-assq id (import-env)))
(aid (cdr imp))
((not (eq? aid (cdr a)))))
(##sys#notice "re-importing already imported identifier" id)))
vsv)
- (for-each
+ (se-for-each
(lambda (imp)
- (and-let* ((a (assq (car imp) (macro-env)))
+ (and-let* ((a (se-assq (car imp) (macro-env)))
((not (eq? (cdr imp) (cdr a)))))
(##sys#notice "re-importing already imported syntax" (car imp))))
vss)
@@ -722,26 +720,26 @@
(##sys#syntax-error-hook loc "`reexport' only valid inside a module"))
(let ((el (module-export-list cm)))
(cond ((eq? #t el)
- (set-module-sexports! cm (append vss (module-sexports cm)))
+ (set-module-sexports! cm (se-append vss (module-sexports cm)))
(set-module-exist-list!
cm
(append (module-exist-list cm)
- (map car vsv)
- (map car vss))))
+ (se-identifiers vsv)
+ (se-identifiers vss))))
(else
(set-module-export-list!
cm
(append
(let ((xl (module-export-list cm)))
(if (eq? #t xl) '() xl))
- (map car vsv)
- (map car vss))))))
+ (se-identifiers vsv)
+ (se-identifiers vss))))))
(set-module-iexports!
cm
(merge-se (module-iexports cm) vsi))
(dm "export-list: " (module-export-list cm)))
- (import-env (append vsv (import-env)))
- (macro-env (append vss (macro-env)))))
+ (import-env (se-append vsv (import-env)))
+ (macro-env (se-append vss (macro-env)))))
(cdr x))
'(##core#undefined))))
@@ -756,7 +754,7 @@
(define (mrename sym)
(cond ((##sys#current-module) =>
(lambda (mod)
- (dm "(ALIAS) global alias " sym " in " (module-name mod))
+ (dm "(ALIAS) global alias `" sym "' in module `" (module-name mod) "'")
(unless assign
(##sys#register-undefined sym mod where))
(##sys#module-rename sym (module-name mod))))
@@ -769,7 +767,7 @@
((getp sym '##core#aliased)
(dm "(ALIAS) marked: " sym)
sym)
- ((assq sym ((##sys#active-eval-environment))) =>
+ ((se-assq sym ((##sys#active-eval-environment))) =>
(lambda (a)
(let ((sym2 (cdr a)))
(dm "(ALIAS) in current environment " sym " -> " sym2)
@@ -870,8 +868,8 @@
(for-each
(lambda (exp)
(let ((sym (if (symbol? exp) exp (car exp))))
- (unless (or (assq sym (module-vexports mod))
- (assq sym (module-sexports mod)))
+ (unless (or (se-assq sym (module-vexports mod))
+ (se-assq sym (module-sexports mod)))
(set! missing (cons sym missing)))))
exps)
(when (pair? missing)
diff --git a/rules.make b/rules.make
index 7e3a9e0..50766ad 100644
--- a/rules.make
+++ b/rules.make
@@ -502,12 +502,13 @@ endef
bootstrap-lib = $(CHICKEN) $(call profile-flags, $@) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
library.c: $(SRCDIR)library.scm $(SRCDIR)banner.scm $(SRCDIR)common-declarations.scm
+ # $(bootstrap-lib) -no-trace
+ $(CHICKEN) $(call profile-flags, $@) $< -no-trace -explicit-use -feature chicken-bootstrap
+eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm $(SRCDIR)ses.scm
$(bootstrap-lib)
-eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm
+expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)ses.scm
$(bootstrap-lib)
-expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
-modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm
+modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)ses.scm
$(bootstrap-lib)
extras.c: $(SRCDIR)extras.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
@@ -522,7 +523,7 @@ irregex.c: $(SRCDIR)irregex.scm $(SRCDIR)irregex-core.scm $(SRCDIR)irregex-utils
#
# The ones below just depend on their matching .scm file and common-declarations
#
-chicken-syntax.c: $(SRCDIR)chicken-syntax.scm $(SRCDIR)common-declarations.scm
+chicken-syntax.c: $(SRCDIR)chicken-syntax.scm $(SRCDIR)common-declarations.scm $(SRCDIR)ses.scm
$(bootstrap-lib)
chicken-ffi-syntax.c: $(SRCDIR)chicken-ffi-syntax.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
@@ -599,7 +600,11 @@ setup-api.c: $(SRCDIR)setup-api.scm
-output-file $@
setup-download.c: $(SRCDIR)setup-download.scm setup-api.c
$(CHICKEN) $< $(CHICKEN_DYNAMIC_OPTIONS) -emit-import-library setup-download \
- -output-file $@
+ -output-file $@
+
+chicken.c: $(SRCDIR)ses.scm
+compiler.c: $(SRCDIR)ses.scm
+compiler-syntax.c: $(SRCDIR)ses.scm
# distribution files
diff --git a/ses.scm b/ses.scm
new file mode 100644
index 0000000..db15e5e
--- /dev/null
+++ b/ses.scm
@@ -0,0 +1,198 @@
+(declare (not inline se-assq))
+(use (only srfi-1 fold))
+
+(define (make-se #!optional (entries '()))
+ (assert (not (real-se? entries)))
+ (cons entries 'cant-touch-this)
+ ;; entries
+ )
+
+(define (se-derive-new se)
+ (assert (valid-se? se))
+ (make-se (car se)))
+
+(define (se-entries se)
+ (assert (valid-se? se))
+ (car se))
+
+(define (real-se? se)
+ (and (pair? se) (eq? 'cant-touch-this (cdr se))
+ ;; (or (not (and (pair? (car se))
+ ;; (begin (print "%")
+ ;; (real-se? se))) )
+ ;; (begin (print "muchos sphagetti")
+ ;; #f))
+ ))
+
+(define (mangled-se? se)
+ (and (pair? se)
+ (pair? (cdr se))
+ (let lp ([es (cdr se)]
+ [len 1])
+ (cond
+ [(null? es) #f]
+ [(symbol? (cdr es)) (print "oops " (cdr es) " " len) #t]
+ [else (lp (cdr es) (add1 len))]))))
+
+(define (valid-se? se)
+ (and (real-se? se)
+ (not (mangled-se? se))))
+
+(define (se-assq id se*) ; ignores macro bindings
+ (assert (valid-se? se*))
+ (assq id (car se*)))
+
+(define (lookup id se)
+ (assert (valid-se? se))
+ (let ([r (cond ((##core#inline "C_u_i_assq" id (car se)) => cdr)
+ ((##core#inline "C_i_getprop" id '##core#macro-alias #f)
+ ;; (getp id '##core#macro-alias)
+ )
+ (else #f))])
+ ;; (print "lookup " id " -> " (cond
+ ;; [(and (pair? r) (= 2 (length r))) (cons 'something (second r))]
+ ;; [r]
+ ;; [else 'NOT-FOUND]))
+ r))
+
+(define (find-id id se*) ; ignores macro bindings
+ (assert (valid-se? se*))
+ (let lp ([se (car se*)])
+ (cond ((null? se) #f)
+ ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
+ (else (lp (cdr se))))))
+
+(define (find-id/alias id se*) ; ignores macro bindings
+ (assert (valid-se? se*))
+ (or (find-id id se*)
+ ;;XXX could hint at decl (3rd arg)
+ (##sys#alias-global-hook id #t #f)))
+
+(define (se-rename var se)
+ (assert (valid-se? se))
+ (cond ((find-id var se))
+ ((##sys#get var '##core#macro-alias))
+ (else var)))
+
+(define (se-assq-reverse id se*)
+ (assert (valid-se? se*))
+ (define (assq-reverse s l)
+ (cond
+ ((null? l) #f)
+ ((eq? (cdar l) s) (car l))
+ (else (assq-reverse s (cdr l)))))
+ (assq-reverse id (car se*)))
+
+(define (se-fold fun se)
+ (assert (valid-se? se))
+ (make-se (fold fun '() (car se))))
+
+(define (merge-se . ses) ; later occurrences take precedence to earlier ones
+ (for-each (lambda (se) (assert (valid-se? se))) ses)
+ (make-se (apply append (map car (reverse ses))))
+
+ ;; (apply append (reverse ses))
+ )
+
+(define (se->list se)
+ (assert (valid-se? se))
+ (car se))
+
+(define (se-append . ses)
+ (for-each (lambda (se) (assert (valid-se? se))) ses)
+ (make-se (apply append (map car ses))))
+
+(define (se-identifiers se)
+ (assert (valid-se? se))
+ (map car (car se)))
+
+(define (se-size se)
+ (length (se-identifiers se)))
+
+(define (se-cons name data se)
+ (assert (valid-se? se))
+ (set-car! se (cons (cons name data) (car se)))
+ se)
+
+(define (se-empty? se)
+ (assert (valid-se? se) "real-se? se-empty?")
+ (null? (car se)))
+
+(define (se-for-each fun se)
+ (assert (valid-se? se))
+ (for-each fun (car se)))
+
+(define (se-map fun se)
+ (assert (valid-se? se))
+ (make-se (map fun (car se))))
+
+(define (se-not-tail tail se)
+ ;; original from expand.scm
+ ;; (let loop ((me (##sys#macro-environment)))
+ ;; (if (or (null? me) (eq? me me0))
+ ;; '()
+ ;; (cons (car me) (loop (cdr me)))))
+
+ (assert (valid-se? se))
+ (assert (valid-se? tail))
+ (let ([tail* (car tail)]
+ [se* (car se)])
+ (make-se (let loop ((me se*))
+ (if (or (null? me) (eq? me tail*))
+ '()
+ (cons (car me) (loop (cdr me))))))))
+
+(define (%%se-find-ids ids . ses) ; returns (values missing-ids . found-ids)
+ (let* ([missing '()]
+ [fss (fold
+ (lambda (id fss)
+ (let* ([found? #f]
+ [r (map (lambda (fs se) (cond [(se-assq id se) (set! found? #t) (cons id fs)]
+ [else fs]))
+ fss ses)])
+ (unless found?
+ (set! missing (cons id missing)))
+ r))
+ (map (lambda _ (list)) ses)
+ ids)])
+ (apply values missing fss)))
+
+(define (se-derive-except ids . ses) ; returns (values missing-ids . derived-ses)
+ (receive ret (apply %%se-find-ids ids ses)
+ (let ([missing (car ret)]
+ [fss (cdr ret)])
+ (apply values missing
+ (map (lambda (ids2 se)
+ (if (null? ids2)
+ se
+ (se-fold (lambda (e es) (cond [(memq (car e) ids2) es]
+ [else (cons e es)]))
+ se)))
+ fss
+ ses)))))
+
+(define (se-derive-rename renames . ses) ; returns (values missing-ids . derived-ses)
+ (receive ret (apply %%se-find-ids (map car renames) ses)
+ (let ([missing (car ret)]
+ [fss (cdr ret)])
+ (apply values missing
+ (map (lambda (ids2 se)
+ (if (null? ids2)
+ se
+ (se-fold (lambda (e es) (cond [(assq (car e) renames)
+ => (lambda (r) (cons (cons (cadr r) (cdr e)) es))]
+ [else (cons e es)]))
+ se)))
+ fss
+ ses)))))
+
+(define (se-derive-prefix prefix-str se)
+ (assert (valid-se? se))
+ (define (ren imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append prefix-str (##sys#symbol->string (car imp))))
+ (cdr imp)))
+ (se-map ren se))
+
+
diff --git a/tests/runtests.sh b/tests/runtests.sh
index f61b4ef..e7e7384 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -64,7 +64,7 @@ TYPESDB=../types.db
cp $TYPESDB test-repository/types.db
time=time
-compile="../csc -types ${TYPESDB} -ignore-repository ${COMPILE_OPTIONS} -o a.out"
+compile="../csc -debug-level 2 -types ${TYPESDB} -ignore-repository ${COMPILE_OPTIONS} -o a.out"
compile2="../csc -compiler $CHICKEN -v -I${TEST_DIR}/.. -L${TEST_DIR}/.. -include-path ${TEST_DIR}/.."
compile_s="../csc -s -types ${TYPESDB} -ignore-repository ${COMPILE_OPTIONS} -v -I${TEST_DIR}/.. -L${TEST_DIR}/.. -include-path ${TEST_DIR}/.."
interpret="../csi -n -include-path ${TEST_DIR}/.."