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}/.."