Ticket #1309: 0001-Let-macros-know-if-they-run-at-toplevel.patch
| File 0001-Let-macros-know-if-they-run-at-toplevel.patch, 38.5 KB (added by , 7 years ago) |
|---|
-
NEWS
From 4033a9c29332146882a984f7cd183c50610f45b0 Mon Sep 17 00:00:00 2001 From: Peter Bex <peter@more-magic.net> Date: Thu, 8 Dec 2016 21:40:45 +0100 Subject: [PATCH] Let macros know if they run at toplevel. This allows us to error out when encountering a definition in an "expression context" (i.e., not at toplevel or in a place where an internal define is allowed) Fixes #1309 --- NEWS | 2 + chicken-ffi-syntax.scm | 3 + chicken-syntax.scm | 5 ++ core.scm | 130 ++++++++++++++++++++--------------------- eval.scm | 151 ++++++++++++++++++++++++------------------------ expand.scm | 94 +++++++++++++++++------------- tests/functor-tests.scm | 2 + 7 files changed, 209 insertions(+), 178 deletions(-) diff --git a/NEWS b/NEWS index 3d78582..5f33cd0 100644
a b 57 57 - Syntax expander 58 58 - Removed support for (define-syntax (foo e r c) ...), which was 59 59 undocumented and not officially supported anyway. 60 - define and friends are now aggressively rejected in "expression 61 contexts" (i.e., anywhere but toplevel or as internal defines). 60 62 61 63 4.11.2 62 64 -
chicken-ffi-syntax.scm
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm index 9bbe73f..0df4cbd 100644
a b 55 55 '() 56 56 (##sys#er-transformer 57 57 (lambda (form r c) 58 (##sys#check-toplevel-definition 'define-external form) 58 59 (let* ((form (cdr form)) 59 60 (quals (and (pair? form) (string? (car form)))) 60 61 (var (and (not quals) (pair? form) (symbol? (car form)))) ) … … 100 101 '() 101 102 (##sys#er-transformer 102 103 (lambda (form r c) 104 (##sys#check-toplevel-definition 'define-location form) 103 105 (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1))) 104 106 (let ((var (cadr form)) 105 107 (type (caddr form)) … … 212 214 '() 213 215 (##sys#er-transformer 214 216 (lambda (form r c) 217 (##sys#check-toplevel-definition 'define-foreign-variable form) 215 218 `(##core#define-foreign-variable ,@(cdr form))))) 216 219 217 220 (##sys#extend-macro-environment -
chicken-syntax.scm
diff --git a/chicken-syntax.scm b/chicken-syntax.scm index b4a19a1..4937ff1 100644
a b 56 56 '() 57 57 (##sys#er-transformer 58 58 (lambda (form r c) 59 (##sys#check-toplevel-definition 'define-constant form) 59 60 (##sys#check-syntax 'define-constant form '(_ symbol _)) 60 61 `(##core#define-constant ,@(cdr form))))) 61 62 … … 63 64 'define-record '() 64 65 (##sys#er-transformer 65 66 (lambda (x r c) 67 (##sys#check-toplevel-definition 'define-record x) ; clearer error 66 68 (##sys#check-syntax 'define-record x '(_ symbol . _)) 67 69 (let* ((name (cadr x)) 68 70 (slots (cddr x)) … … 354 356 'define-values '() 355 357 (##sys#er-transformer 356 358 (lambda (form r c) 359 (##sys#check-toplevel-definition 'define-values form) 357 360 (##sys#check-syntax 'define-values form '(_ lambda-list _)) 358 361 (##sys#decompose-lambda-list 359 362 (cadr form) … … 467 470 'define-inline '() 468 471 (##sys#er-transformer 469 472 (lambda (form r c) 473 (##sys#check-toplevel-definition 'define-inline form) 470 474 (letrec ([quotify-proc 471 475 (lambda (xs id) 472 476 (##sys#check-syntax id xs '#(_ 1)) … … 840 844 'define-record-printer '() 841 845 (##sys#er-transformer 842 846 (lambda (form r c) 847 ;; TODO: Only allow at toplevel? It's not really a definition... 843 848 (##sys#check-syntax 'define-record-printer form '(_ _ . _)) 844 849 (let ([head (cadr form)] 845 850 [body (cddr form)]) -
core.scm
diff --git a/core.scm b/core.scm index db6337d..e0a18b9 100644
a b 529 529 (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se))) 530 530 (cond ((not (symbol? x)) x0) ; syntax? 531 531 ((##sys#hash-table-ref constant-table x) 532 => (lambda (val) (walk val e se dest ldest h #f )))532 => (lambda (val) (walk val e se dest ldest h #f #f))) 533 533 ((##sys#hash-table-ref inline-table x) 534 => (lambda (val) (walk val e se dest ldest h #f )))534 => (lambda (val) (walk val e se dest ldest h #f #f))) 535 535 ((assq x foreign-variables) 536 536 => (lambda (fv) 537 537 (let* ((t (second fv)) … … 541 541 (foreign-type-convert-result 542 542 (finish-foreign-result ft body) 543 543 t) 544 e se dest ldest h #f ))))544 e se dest ldest h #f #f)))) 545 545 ((assq x location-pointer-map) 546 546 => (lambda (a) 547 547 (let* ((t (third a)) … … 551 551 (foreign-type-convert-result 552 552 (finish-foreign-result ft body) 553 553 t) 554 e se dest ldest h #f ))))554 e se dest ldest h #f #f)))) 555 555 ((##sys#get x '##core#primitive)) 556 556 ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global 557 557 (else x)))) … … 579 579 (for-each pretty-print imps) 580 580 (print "\n;; END OF FILE"))))) ) ) 581 581 582 (define (walk x e se dest ldest h outer-ln )582 (define (walk x e se dest ldest h outer-ln tl?) 583 583 (cond ((symbol? x) 584 584 (cond ((keyword? x) `(quote ,x)) 585 585 ((memq x unlikely-variables) … … 600 600 (set! ##sys#syntax-error-culprit x) 601 601 (let* ((name0 (lookup (car x) se)) 602 602 (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0)) 603 (xexpanded (expand x se compiler-syntax-enabled )))603 (xexpanded (expand x se compiler-syntax-enabled tl?))) 604 604 (when ln (update-line-number-database! xexpanded ln)) 605 605 (cond ((not (eq? x xexpanded)) 606 (walk xexpanded e se dest ldest h ln ))606 (walk xexpanded e se dest ldest h ln tl?)) 607 607 608 608 ((##sys#hash-table-ref inline-table name) 609 609 => (lambda (val) 610 (walk (cons val (cdr x)) e se dest ldest h ln )))610 (walk (cons val (cdr x)) e se dest ldest h ln #f))) 611 611 612 612 (else 613 613 (case name 614 614 615 615 ((##core#if) 616 616 `(if 617 ,(walk (cadr x) e se #f #f h ln )618 ,(walk (caddr x) e se #f #f h ln )617 ,(walk (cadr x) e se #f #f h ln #f) 618 ,(walk (caddr x) e se #f #f h ln #f) 619 619 ,(if (null? (cdddr x)) 620 620 '(##core#undefined) 621 (walk (cadddr x) e se #f #f h ln ) ) ) )621 (walk (cadddr x) e se #f #f h ln #f) ) ) ) 622 622 623 623 ((##core#syntax ##core#quote) 624 624 `(quote ,(strip-syntax (cadr x)))) … … 626 626 ((##core#check) 627 627 (if unsafe 628 628 ''#t 629 (walk (cadr x) e se dest ldest h ln ) ) )629 (walk (cadr x) e se dest ldest h ln tl?) ) ) 630 630 631 631 ((##core#the) 632 632 `(##core#the 633 633 ,(strip-syntax (cadr x)) 634 634 ,(caddr x) 635 ,(walk (cadddr x) e se dest ldest h ln )))635 ,(walk (cadddr x) e se dest ldest h ln tl?))) 636 636 637 637 ((##core#typecase) 638 638 `(##core#typecase 639 639 ,(or ln (cadr x)) 640 ,(walk (caddr x) e se #f #f h ln )640 ,(walk (caddr x) e se #f #f h ln tl?) 641 641 ,@(map (lambda (cl) 642 642 (list (strip-syntax (car cl)) 643 (walk (cadr cl) e se dest ldest h ln )))643 (walk (cadr cl) e se dest ldest h ln tl?))) 644 644 (cdddr x)))) 645 645 646 646 ((##core#immutable) … … 667 667 ((##core#inline_loc_ref) 668 668 `(##core#inline_loc_ref 669 669 ,(strip-syntax (cadr x)) 670 ,(walk (caddr x) e se dest ldest h ln )))670 ,(walk (caddr x) e se dest ldest h ln #f))) 671 671 672 672 ((##core#require-for-syntax) 673 673 (load-extension (cadr x)) … … 683 683 file-requirements type 684 684 (cut lset-adjoin/eq? <> id) 685 685 (cut list id))) 686 (walk exp e se dest ldest h ln ))))686 (walk exp e se dest ldest h ln #f)))) 687 687 688 688 ((##core#let) 689 689 (let* ((bindings (cadr x)) … … 693 693 (set-real-names! aliases vars) 694 694 `(let 695 695 ,(map (lambda (alias b) 696 (list alias (walk (cadr b) e se (car b) #t h ln )) )696 (list alias (walk (cadr b) e se (car b) #t h ln #f)) ) 697 697 aliases bindings) 698 698 ,(walk (##sys#canonicalize-body 699 699 (cddr x) se2 compiler-syntax-enabled) 700 700 (append aliases e) 701 se2 dest ldest h ln ) ) ) )701 se2 dest ldest h ln #f) ) ) ) 702 702 703 703 ((##core#letrec*) 704 704 (let ((bindings (cadr x)) … … 712 712 `(##core#set! ,(car b) ,(cadr b))) 713 713 bindings) 714 714 (##core#let () ,@body) ) 715 e se dest ldest h ln )))715 e se dest ldest h ln #f))) 716 716 717 717 ((##core#letrec) 718 718 (let* ((bindings (cadr x)) … … 730 730 `(##core#set! ,v ,t)) 731 731 vars tmps) 732 732 (##core#let () ,@body) ) ) 733 e se dest ldest h ln )))733 e se dest ldest h ln #f))) 734 734 735 735 ((##core#lambda) 736 736 (let ((llist (cadr x)) … … 753 753 (##core#debug-event "C_DEBUG_ENTRY" ',dest) 754 754 ,body0) 755 755 body0) 756 (append aliases e) se2 #f #f dest ln ))756 (append aliases e) se2 #f #f dest ln #f)) 757 757 (llist2 758 758 (build-lambda-list 759 759 aliases argc … … 790 790 (walk 791 791 (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled) 792 792 e se2 793 dest ldest h ln ) ) )793 dest ldest h ln #f) ) ) 794 794 795 795 ((##core#letrec-syntax) 796 796 (let* ((ms (map (lambda (b) … … 808 808 ms) 809 809 (walk 810 810 (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled) 811 e se2 dest ldest h ln )))811 e se2 dest ldest h ln #f))) 812 812 813 813 ((##core#define-syntax) 814 814 (##sys#check-syntax … … 833 833 ',var 834 834 (##sys#current-environment) ,body) ;XXX possibly wrong se? 835 835 '(##core#undefined) ) 836 e se dest ldest h ln )) )836 e se dest ldest h ln #f)) ) 837 837 838 838 ((##core#define-compiler-syntax) 839 839 (let* ((var (cadr x)) … … 865 865 ',var) 866 866 (##sys#current-environment)))) 867 867 '(##core#undefined) ) 868 e se dest ldest h ln )))868 e se dest ldest h ln #f))) 869 869 870 870 ((##core#let-compiler-syntax) 871 871 (let ((bs (map … … 892 892 (walk 893 893 (##sys#canonicalize-body 894 894 (cddr x) se compiler-syntax-enabled) 895 e se dest ldest h ln ) )895 e se dest ldest h ln tl?) ) 896 896 (lambda () 897 897 (for-each 898 898 (lambda (b) … … 907 907 (cadr x) 908 908 (caddr x) 909 909 (lambda (forms) 910 (walk `(##core#begin ,@forms) e se dest ldest h ln )))))910 (walk `(##core#begin ,@forms) e se dest ldest h ln tl?))))) 911 911 912 912 ((##core#let-module-alias) 913 913 (##sys#with-module-aliases … … 916 916 (strip-syntax b)) 917 917 (cadr x)) 918 918 (lambda () 919 (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln ))))919 (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln #t)))) 920 920 921 921 ((##core#module) 922 922 (let* ((name (strip-syntax (cadr x))) … … 986 986 (car body) 987 987 e ;? 988 988 (##sys#current-environment) 989 #f #f h ln )989 #f #f h ln #t) ; reset to toplevel! 990 990 xs)))))))))) 991 991 (let ((body 992 992 (canonicalize-begin-body … … 999 999 (walk 1000 1000 x 1001 1001 e ;? 1002 (##sys#current-meta-environment) #f #f h ln ) )1002 (##sys#current-meta-environment) #f #f h ln tl?) ) 1003 1003 (cons `(##core#provide ,req) module-registration))) 1004 1004 body)))) 1005 1005 (do ((cs compiler-syntax (cdr cs))) … … 1017 1017 (walk 1018 1018 (##sys#canonicalize-body obody se2 compiler-syntax-enabled) 1019 1019 (append aliases e) 1020 se2 #f #f dest ln ) ] )1020 se2 #f #f dest ln #f) ] ) 1021 1021 (set-real-names! aliases vars) 1022 1022 `(##core#lambda ,aliases ,body) ) ) 1023 1023 … … 1039 1039 (##core#inline_update 1040 1040 (,(third fv) ,type) 1041 1041 ,(foreign-type-check tmp type) ) ) 1042 e se #f #f h ln ))))1042 e se #f #f h ln #f)))) 1043 1043 ((assq var location-pointer-map) 1044 1044 => (lambda (a) 1045 1045 (let* ([type (third a)] … … 1050 1050 (,type) 1051 1051 ,(second a) 1052 1052 ,(foreign-type-check tmp type) ) ) 1053 e se #f #f h ln ))))1053 e se #f #f h ln #f)))) 1054 1054 (else 1055 1055 (unless (memq var e) ; global? 1056 1056 (set! var (or (##sys#get var '##core#primitive) … … 1074 1074 (##sys#notice "assignment to imported value binding" var))) 1075 1075 (when (keyword? var) 1076 1076 (warning (sprintf "assignment to keyword `~S'" var) )) 1077 `(set! ,var ,(walk val e se var0 (memq var e) h ln ))))))1077 `(set! ,var ,(walk val e se var0 (memq var e) h ln #f)))))) 1078 1078 1079 1079 ((##core#debug-event) 1080 1080 `(##core#debug-event 1081 1081 ,(unquotify (cadr x) se) 1082 1082 ,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument! 1083 1083 ,@(map (lambda (arg) 1084 (unquotify (walk arg e se #f #f h ln ) se))1084 (unquotify (walk arg e se #f #f h ln tl?) se)) 1085 1085 (cddr x)))) 1086 1086 1087 1087 ((##core#inline) 1088 1088 `(##core#inline 1089 ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln )))1089 ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln #f))) 1090 1090 1091 1091 ((##core#inline_allocate) 1092 1092 `(##core#inline_allocate 1093 1093 ,(map (cut unquotify <> se) (second x)) 1094 ,@(mapwalk (cddr x) e se h ln )))1094 ,@(mapwalk (cddr x) e se h ln #f))) 1095 1095 1096 1096 ((##core#inline_update) 1097 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln )) )1097 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln #f)) ) 1098 1098 1099 1099 ((##core#inline_loc_update) 1100 1100 `(##core#inline_loc_update 1101 1101 ,(cadr x) 1102 ,(walk (caddr x) e se #f #f h ln )1103 ,(walk (cadddr x) e se #f #f h ln )) )1102 ,(walk (caddr x) e se #f #f h ln #f) 1103 ,(walk (cadddr x) e se #f #f h ln #f)) ) 1104 1104 1105 1105 ((##core#compiletimetoo ##core#elaborationtimetoo) 1106 1106 (let ((exp (cadr x))) 1107 1107 (##sys#eval/meta exp) 1108 (walk exp e se dest #f h ln ) ) )1108 (walk exp e se dest #f h ln tl?) ) ) 1109 1109 1110 1110 ((##core#compiletimeonly ##core#elaborationtimeonly) 1111 1111 (##sys#eval/meta (cadr x)) … … 1118 1118 (let ([x (car xs)] 1119 1119 [r (cdr xs)] ) 1120 1120 (if (null? r) 1121 (list (walk x e se dest ldest h ln ))1122 (cons (walk x e se #f #f h ln ) (fold r)) ) ) ) )1121 (list (walk x e se dest ldest h ln tl?)) 1122 (cons (walk x e se #f #f h ln tl?) (fold r)) ) ) ) ) 1123 1123 '(##core#undefined) ) ) 1124 1124 1125 1125 ((##core#foreign-lambda) 1126 (walk (expand-foreign-lambda x #f) e se dest ldest h ln ) )1126 (walk (expand-foreign-lambda x #f) e se dest ldest h ln #f) ) 1127 1127 1128 1128 ((##core#foreign-safe-lambda) 1129 (walk (expand-foreign-lambda x #t) e se dest ldest h ln ) )1129 (walk (expand-foreign-lambda x #t) e se dest ldest h ln #f) ) 1130 1130 1131 1131 ((##core#foreign-lambda*) 1132 (walk (expand-foreign-lambda* x #f) e se dest ldest h ln ) )1132 (walk (expand-foreign-lambda* x #f) e se dest ldest h ln #f) ) 1133 1133 1134 1134 ((##core#foreign-safe-lambda*) 1135 (walk (expand-foreign-lambda* x #t) e se dest ldest h ln ) )1135 (walk (expand-foreign-lambda* x #t) e se dest ldest h ln #f) ) 1136 1136 1137 1137 ((##core#foreign-primitive) 1138 (walk (expand-foreign-primitive x) e se dest ldest h ln ) )1138 (walk (expand-foreign-primitive x) e se dest ldest h ln #f) ) 1139 1139 1140 1140 ((##core#define-foreign-variable) 1141 1141 (let* ((var (strip-syntax (second x))) … … 1169 1169 (define 1170 1170 ,ret 1171 1171 ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) 1172 e se dest ldest h ln ) ) ]1172 e se dest ldest h ln #f) ) ] 1173 1173 [else 1174 1174 (register-foreign-type! name type) 1175 1175 '(##core#undefined) ] ) ) ) … … 1212 1212 '() ) 1213 1213 ,(if init (fifth x) (fourth x)) ) ) 1214 1214 e (alist-cons var alias se) 1215 dest ldest h ln ) ) )1215 dest ldest h ln #f) ) ) 1216 1216 1217 1217 ((##core#define-inline) 1218 1218 (let* ((name (second x)) … … 1244 1244 (hide-variable var) 1245 1245 (mark-variable var '##compiler#constant) 1246 1246 (mark-variable var '##compiler#always-bound) 1247 (walk `(define ,var (##core#quote ,val)) e se #f #f h ln )))1247 (walk `(define ,var (##core#quote ,val)) e se #f #f h ln tl?))) 1248 1248 (else 1249 1249 (quit-compiling "invalid compile-time value for named constant `~S'" 1250 1250 name))))) … … 1258 1258 (lambda (id) 1259 1259 (memq (lookup id se) e)))) 1260 1260 (cdr x) ) ) 1261 e '() #f #f h ln ) )1261 e '() #f #f h ln #f) ) 1262 1262 1263 1263 ((##core#foreign-callback-wrapper) 1264 1264 (let-values ([(args lam) (split-at (cdr x) 4)]) … … 1280 1280 "non-matching or invalid argument list to foreign callback-wrapper" 1281 1281 vars atypes) ) 1282 1282 `(##core#foreign-callback-wrapper 1283 ,@(mapwalk args e se h ln )1283 ,@(mapwalk args e se h ln #f) 1284 1284 ,(walk `(##core#lambda 1285 1285 ,vars 1286 1286 (##core#let … … 1337 1337 (##sys#make-c-string r ',name)) ) ) ) 1338 1338 (else (cddr lam)) ) ) 1339 1339 rtype) ) ) 1340 e se #f #f h ln ) ) ) ) )1340 e se #f #f h ln #f) ) ) ) ) 1341 1341 1342 1342 ((##core#location) 1343 1343 (let ([sym (cadr x)]) … … 1346 1346 => (lambda (a) 1347 1347 (walk 1348 1348 `(##sys#make-locative ,(second a) 0 #f 'location) 1349 e se #f #f h ln ) ) ]1349 e se #f #f h ln #f) ) ] 1350 1350 [(assq sym external-to-pointer) 1351 => (lambda (a) (walk (cdr a) e se #f #f h ln )) ]1351 => (lambda (a) (walk (cdr a) e se #f #f h ln #f)) ] 1352 1352 [(assq sym callback-names) 1353 1353 `(##core#inline_ref (,(symbol->string sym) c-pointer)) ] 1354 1354 [else 1355 1355 (walk 1356 1356 `(##sys#make-locative ,sym 0 #f 'location) 1357 e se #f #f h ln ) ] )1357 e se #f #f h ln #f) ] ) 1358 1358 (walk 1359 1359 `(##sys#make-locative ,sym 0 #f 'location) 1360 e se #f #f h ln ) ) ) )1360 e se #f #f h ln #f) ) ) ) 1361 1361 1362 1362 (else 1363 1363 (let* ((x2 (fluid-let ((##sys#syntax-context 1364 1364 (cons name ##sys#syntax-context))) 1365 (mapwalk x e se h ln )))1365 (mapwalk x e se h ln tl?))) 1366 1366 (head2 (car x2)) 1367 1367 (old (##sys#hash-table-ref line-number-database-2 head2)) ) 1368 1368 (when ln … … 1378 1378 ((constant? (car x)) 1379 1379 (emit-syntax-trace-info x #f) 1380 1380 (warning "literal in operator position" x) 1381 (mapwalk x e se h outer-ln ) )1381 (mapwalk x e se h outer-ln tl?) ) 1382 1382 1383 1383 (else 1384 1384 (emit-syntax-trace-info x #f) … … 1387 1387 `(##core#let 1388 1388 ((,tmp ,(car x))) 1389 1389 (,tmp ,@(cdr x))) 1390 e se dest ldest h outer-ln )))))1390 e se dest ldest h outer-ln #f))))) 1391 1391 1392 (define (mapwalk xs e se h ln )1393 (map (lambda (x) (walk x e se #f #f h ln )) xs) )1392 (define (mapwalk xs e se h ln tl?) 1393 (map (lambda (x) (walk x e se #f #f h ln tl?)) xs) ) 1394 1394 1395 1395 (when (memq 'c debugging-chicken) (newline) (pretty-print exp)) 1396 1396 (foreign-code "C_clear_trace_buffer();") … … 1403 1403 ,(begin 1404 1404 (set! extended-bindings (append internal-bindings extended-bindings)) 1405 1405 exp) ) 1406 '() (##sys#current-environment) #f #f #f #f ) ) )1406 '() (##sys#current-environment) #f #f #f #f #t) ) ) 1407 1407 1408 1408 1409 1409 (define (process-declaration spec se local?) -
eval.scm
diff --git a/eval.scm b/eval.scm index c43e444..bddc5f3 100644
a b 207 207 208 208 (define compile-to-closure 209 209 (let ((reverse reverse)) 210 (lambda (exp env se #!optional cntr evalenv static )210 (lambda (exp env se #!optional cntr evalenv static tl?) 211 211 212 212 (define (find-id id se) ; ignores macro bindings 213 213 (cond ((null? se) #f) … … 252 252 (define (decorate p ll h cntr) 253 253 (eval-decorator p ll h cntr)) 254 254 255 (define (compile x e h tf cntr se )255 (define (compile x e h tf cntr se tl?) 256 256 (cond ((keyword? x) (lambda v x)) 257 257 ((symbol? x) 258 258 (receive (i j) (lookup x e se) … … 315 315 (##sys#syntax-error/context "illegal non-atomic object" x)] 316 316 [(symbol? (##sys#slot x 0)) 317 317 (emit-syntax-trace-info tf x cntr) 318 (let ((x2 (expand x se )))318 (let ((x2 (expand x se #f tl?))) 319 319 (d `(EVAL/EXPANDED: ,x2)) 320 320 (if (not (eq? x2 x)) 321 (compile x2 e h tf cntr se )321 (compile x2 e h tf cntr se tl?) 322 322 (let ((head (rename (##sys#slot x 0) se))) 323 323 ;; here we did't resolve ##core#primitive, but that is done in compile-call (via 324 324 ;; a normal walking of the operator) … … 341 341 (lambda v c))) 342 342 343 343 [(##core#check) 344 (compile (cadr x) e h tf cntr se ) ]344 (compile (cadr x) e h tf cntr se #f) ] 345 345 346 346 [(##core#immutable) 347 (compile (cadr x) e #f tf cntr se ) ]347 (compile (cadr x) e #f tf cntr se #f) ] 348 348 349 349 [(##core#undefined) (lambda (v) (##core#undefined))] 350 350 351 351 [(##core#if) 352 (let* ( [test (compile (cadr x) e #f tf cntr se)]353 [cns (compile (caddr x) e #f tf cntr se)]354 [alt (if (pair? (cdddr x))355 (compile (cadddr x) e #f tf cntr se )356 (compile '(##core#undefined) e #f tf cntr se ) ) ])352 (let* ((test (compile (cadr x) e #f tf cntr se #f)) 353 (cns (compile (caddr x) e #f tf cntr se #f)) 354 (alt (if (pair? (cdddr x)) 355 (compile (cadddr x) e #f tf cntr se #f) 356 (compile '(##core#undefined) e #f tf cntr se #f) ) ) ) 357 357 (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ] 358 358 359 359 [(##core#begin) 360 360 (let* ((body (##sys#slot x 1)) 361 361 (len (length body)) ) 362 362 (case len 363 [(0) (compile '(##core#undefined) e #f tf cntr se)]364 [(1) (compile (##sys#slot body 0) e #f tf cntr se)]365 [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]366 [x2 (compile (cadr body) e #f tf cntr se )] )367 (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]368 [else369 (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se )]370 [x2 (compile (cadr body) e #f tf cntr se )]371 [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se )] )372 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ]) ) ]363 ((0) (compile '(##core#undefined) e #f tf cntr se tl?)) 364 ((1) (compile (##sys#slot body 0) e #f tf cntr se tl?)) 365 ((2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)] 366 [x2 (compile (cadr body) e #f tf cntr se tl?)] ) 367 (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ) 368 (else 369 (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)] 370 [x2 (compile (cadr body) e #f tf cntr se tl?)] 371 [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se tl?)] ) 372 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ) ) ) ] 373 373 374 374 [(##core#set!) 375 375 (let ((var (cadr x))) 376 376 (receive (i j) (lookup var e se) 377 (let ((val (compile (caddr x) e var tf cntr se )))377 (let ((val (compile (caddr x) e var tf cntr se #f))) 378 378 (cond [(not i) 379 379 (when ##sys#notices-enabled 380 380 (and-let* ((a (assq var (##sys#current-environment))) … … 406 406 (se2 (##sys#extend-se se vars aliases)) 407 407 [body (compile-to-closure 408 408 (##sys#canonicalize-body (cddr x) se2 #f) 409 e2 se2 cntr evalenv static ) ] )409 e2 se2 cntr evalenv static #f) ] ) 410 410 (case n 411 [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se )])411 [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se #f)]) 412 412 (lambda (v) 413 413 (##core#app body (cons (vector (##core#app val v)) v)) ) ) ] 414 [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se )]415 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se )] )414 [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)] 415 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] ) 416 416 (lambda (v) 417 417 (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ] 418 [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se )]419 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se )]418 [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)] 419 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] 420 420 [t (cddr bindings)] 421 [val3 (compile (cadar t) e (caddr vars) tf cntr se )] )421 [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] ) 422 422 (lambda (v) 423 423 (##core#app 424 424 body 425 425 (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ] 426 [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se )]427 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se )]426 [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)] 427 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] 428 428 [t (cddr bindings)] 429 [val3 (compile (cadar t) e (caddr vars) tf cntr se )]430 [val4 (compile (cadadr t) e (cadddr vars) tf cntr se )] )429 [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] 430 [val4 (compile (cadadr t) e (cadddr vars) tf cntr se #f)] ) 431 431 (lambda (v) 432 432 (##core#app 433 433 body … … 437 437 (##core#app val4 v)) 438 438 v)) ) ) ] 439 439 [else 440 (let ( [vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])440 (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se #f)) bindings))) 441 441 (lambda (v) 442 442 (let ([v2 (##sys#make-vector n)]) 443 443 (do ([i 0 (fx+ i 1)] … … 458 458 `(##core#set! ,(car b) ,(cadr b))) 459 459 bindings) 460 460 (##core#let () ,@body) ) 461 e h tf cntr se )))461 e h tf cntr se #f))) 462 462 463 463 ((##core#letrec) 464 464 (let* ((bindings (cadr x)) … … 475 475 `(##core#set! ,v ,t)) 476 476 vars tmps) 477 477 (##core#let () ,@body) ) ) 478 e h tf cntr se )))478 e h tf cntr se #f))) 479 479 480 480 [(##core#lambda) 481 481 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se) … … 496 496 (body 497 497 (compile-to-closure 498 498 (##sys#canonicalize-body body se2 #f) 499 e2 se2 (or h cntr) evalenv static ) ) )499 e2 se2 (or h cntr) evalenv static #f) ) ) 500 500 (case argc 501 501 [(0) (if rest 502 502 (lambda (v) … … 583 583 se) ) ) 584 584 (compile 585 585 (##sys#canonicalize-body (cddr x) se2 #f) 586 e #f tf cntr se2 )))586 e #f tf cntr se2 #f))) 587 587 588 588 ((##core#letrec-syntax) 589 589 (let* ((ms (map (lambda (b) … … 601 601 ms) 602 602 (compile 603 603 (##sys#canonicalize-body (cddr x) se2 #f) 604 e #f tf cntr se2 )))604 e #f tf cntr se2 #f))) 605 605 606 606 ((##core#define-syntax) 607 607 (let* ((var (cadr x)) … … 616 616 name 617 617 (##sys#current-environment) 618 618 (##sys#eval/meta body)) 619 (compile '(##core#undefined) e #f tf cntr se ) ) )619 (compile '(##core#undefined) e #f tf cntr se #f) ) ) 620 620 621 621 ((##core#define-compiler-syntax) 622 (compile '(##core#undefined) e #f tf cntr se ))622 (compile '(##core#undefined) e #f tf cntr se #f)) 623 623 624 624 ((##core#let-compiler-syntax) 625 625 (compile 626 626 (##sys#canonicalize-body (cddr x) se #f) 627 e #f tf cntr se ))627 e #f tf cntr se #f)) 628 628 629 629 ((##core#include) 630 630 (##sys#include-forms-from-file 631 631 (cadr x) 632 632 (caddr x) 633 633 (lambda (forms) 634 (compile `(##core#begin ,@forms) e #f tf cntr se ))))634 (compile `(##core#begin ,@forms) e #f tf cntr se tl?)))) 635 635 636 636 ((##core#let-module-alias) 637 637 (##sys#with-module-aliases … … 640 640 (strip-syntax b)) 641 641 (cadr x)) 642 642 (lambda () 643 (compile `(##core#begin ,@(cddr x)) e #f tf cntr se ))))643 (compile `(##core#begin ,@(cddr x)) e #f tf cntr se tl?)))) 644 644 645 645 ((##core#module) 646 646 (let* ((x (strip-syntax x)) … … 691 691 (cons (compile 692 692 (car body) 693 693 '() #f tf cntr 694 (##sys#current-environment)) 694 (##sys#current-environment) 695 #t) ; reset back to toplevel! 695 696 xs))))) ) ))) 696 697 697 698 [(##core#loop-lambda) 698 (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se ) ]699 (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se #f) ] 699 700 700 701 [(##core#provide) 701 (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se )]702 (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se #f)] 702 703 703 704 [(##core#require-for-syntax) 704 705 (let ((id (cadr x))) … … 708 709 ,@(map (lambda (x) 709 710 `(##sys#load-extension (##core#quote ,x))) 710 711 (lookup-runtime-requirements id))) 711 e #f tf cntr se ))]712 e #f tf cntr se #f))] 712 713 713 714 [(##core#require) 714 715 (let ((id (cadr x)) 715 716 (alternates (cddr x))) 716 717 (let-values (((exp _ _) (##sys#process-require id #f alternates))) 717 (compile exp e #f tf cntr se )))]718 (compile exp e #f tf cntr se #f)))] 718 719 719 720 [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this! 720 721 (##sys#eval/meta (cadr x)) 721 (compile '(##core#undefined) e #f tf cntr se ) ]722 (compile '(##core#undefined) e #f tf cntr se tl?) ] 722 723 723 724 [(##core#compiletimetoo) 724 (compile (cadr x) e #f tf cntr se ) ]725 (compile (cadr x) e #f tf cntr se tl?) ] 725 726 726 727 [(##core#compiletimeonly ##core#callunit) 727 (compile '(##core#undefined) e #f tf cntr se ) ]728 (compile '(##core#undefined) e #f tf cntr se tl?) ] 728 729 729 730 [(##core#declare) 730 731 (##sys#notice "declarations are ignored in interpreted code" x) 731 (compile '(##core#undefined) e #f tf cntr se ) ]732 (compile '(##core#undefined) e #f tf cntr se #f) ] 732 733 733 734 [(##core#define-inline ##core#define-constant) 734 (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se ) ]735 (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se #f) ] 735 736 736 737 [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 737 738 ##core#define-foreign-variable … … 744 745 (compile-call (cdr x) e tf cntr se) ] 745 746 746 747 ((##core#the) 747 (compile (cadddr x) e h tf cntr se ))748 (compile (cadddr x) e h tf cntr se tl?)) 748 749 749 750 ((##core#typecase) 750 751 ;; drops exp and requires "else" clause 751 752 (cond ((assq 'else (strip-syntax (cdddr x))) => 752 753 (lambda (cl) 753 (compile (cadr cl) e h tf cntr se )))754 (compile (cadr cl) e h tf cntr se tl?))) 754 755 (else 755 756 (##sys#syntax-error-hook 756 757 'compiler-typecase … … 789 790 (let* ((head (##sys#slot x 0)) 790 791 (fn (if (procedure? head) 791 792 (lambda _ head) 792 (compile (##sys#slot x 0) e #f tf cntr se )))793 (compile (##sys#slot x 0) e #f tf cntr se #f))) 793 794 (args (##sys#slot x 1)) 794 795 (argc (checked-length args)) 795 796 (info x) ) … … 798 799 [(0) (lambda (v) 799 800 (emit-trace-info tf info cntr e v) 800 801 ((##core#app fn v)))] 801 [(1) (let ( [a1 (compile (##sys#slot args 0) e #f tf cntr se)])802 [(1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))) 802 803 (lambda (v) 803 804 (emit-trace-info tf info cntr e v) 804 805 ((##core#app fn v) (##core#app a1 v))) ) ] 805 [(2) (let* ( [a1 (compile (##sys#slot args 0) e #f tf cntr se)]806 [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)])806 [(2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)) 807 (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) ) 807 808 (lambda (v) 808 809 (emit-trace-info tf info cntr e v) 809 810 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ] 810 [(3) (let* ( [a1 (compile (##sys#slot args 0) e #f tf cntr se)]811 [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]812 [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)])811 [(3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)) 812 (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) 813 (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) ) 813 814 (lambda (v) 814 815 (emit-trace-info tf info cntr e v) 815 816 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ] 816 [(4) (let* ( [a1 (compile (##sys#slot args 0) e #f tf cntr se)]817 [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]818 [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)]819 [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)])817 [(4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)) 818 (a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) 819 (a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) 820 (a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se #f)) ) 820 821 (lambda (v) 821 822 (emit-trace-info tf info cntr e v) 822 823 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ] 823 [else (let ( [as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])824 [else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr se #f)) args))) 824 825 (lambda (v) 825 826 (emit-trace-info tf info cntr e v) 826 827 (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) ) 827 828 828 (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se ) ) ) )829 (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se tl?) ) ) ) 829 830 830 831 831 832 ;;; evaluate in the macro-expansion/compile-time environment … … 846 847 ((compile-to-closure 847 848 form 848 849 '() 849 (##sys#current-meta-environment)) ;XXX evalenv? static? 850 '() ) ) 850 (##sys#current-meta-environment) 851 #f #f #f ;XXX evalenv? static? 852 #t) ; toplevel. 853 '()) ) 851 854 (lambda () 852 855 (##sys#active-eval-environment aee) 853 856 (##sys#current-module oldcm) … … 865 868 (let ((se2 (##sys#slot env 2))) 866 869 ((if se2 ; not interaction-environment? 867 870 (parameterize ((##sys#macro-environment '())) 868 (compile-to-closure x '() se2 #f env (##sys#slot env 3) ))869 (compile-to-closure x '() se #f env #f ))871 (compile-to-closure x '() se2 #f env (##sys#slot env 3) #t)) 872 (compile-to-closure x '() se #f env #f #t)) 870 873 '() ) ) ) 871 874 (else 872 ((compile-to-closure x '() se #f #f #f ) '())))))))875 ((compile-to-closure x '() se #f #f #f #t) '()))))))) 873 876 874 877 (define (eval x . env) 875 878 (apply (eval-handler) x env)) -
expand.scm
diff --git a/expand.scm b/expand.scm index 783b34d..2548309 100644
a b 209 209 210 210 ;; The basic macro-expander 211 211 212 (define (##sys#expand-0 exp dse cs? )212 (define (##sys#expand-0 exp dse cs? toplevel?) 213 213 (define (call-handler name handler exp se cs) 214 214 (dd "invoking macro: " name) 215 215 (dd `(STATIC-SE: ,@(map-se se))) … … 272 272 (call-handler head (cadr mdef) exp (car mdef) #f) 273 273 #t)) 274 274 (else (values exp #f)) ) ) 275 (let loop ((exp exp)) 276 (if (pair? exp) 277 (let ((head (car exp)) 278 (body (cdr exp)) ) 279 (if (symbol? head) 280 (let ((head2 (or (lookup head dse) head))) 281 (unless (pair? head2) 282 (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) ) 283 (cond [(eq? head2 '##core#let) 284 (##sys#check-syntax 'let body '#(_ 2) #f dse) 285 (let ([bindings (car body)]) 286 (cond [(symbol? bindings) ; expand named let 287 (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse) 288 (let ([bs (cadr body)]) 289 (values 290 `(##core#app 291 (##core#letrec* 292 ([,bindings 293 (##core#loop-lambda 294 ,(map (lambda (b) (car b)) bs) ,@(cddr body))]) 295 ,bindings) 296 ,@(##sys#map cadr bs) ) 297 #t) ) ] 298 [else (values exp #f)] ) ) ] 299 ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) => 300 (lambda (cs) 301 (let ((result (call-handler head (car cs) exp (cdr cs) #t))) 302 (cond ((eq? result exp) (expand head exp head2)) 303 (else 304 (when ##sys#compiler-syntax-hook 305 (##sys#compiler-syntax-hook head result)) 306 (loop result)))))) 307 [else (expand head exp head2)] ) ) 308 (values exp #f) ) ) 309 (values exp #f) ) ) ) 275 (fluid-let ((##sys#at-toplevel toplevel?)) 276 (let loop ((exp exp)) 277 (if (pair? exp) 278 (let ((head (car exp)) 279 (body (cdr exp)) ) 280 (if (symbol? head) 281 (let ((head2 (or (lookup head dse) head))) 282 (unless (pair? head2) 283 (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) ) 284 (cond [(eq? head2 '##core#let) 285 (##sys#check-syntax 'let body '#(_ 2) #f dse) 286 (let ([bindings (car body)]) 287 (cond [(symbol? bindings) ; expand named let 288 (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse) 289 (let ([bs (cadr body)]) 290 (values 291 `(##core#app 292 (##core#letrec* 293 ([,bindings 294 (##core#loop-lambda 295 ,(map (lambda (b) (car b)) bs) ,@(cddr body))]) 296 ,bindings) 297 ,@(##sys#map cadr bs) ) 298 #t) ) ] 299 [else (values exp #f)] ) ) ] 300 ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) => 301 (lambda (cs) 302 (let ((result (call-handler head (car cs) exp (cdr cs) #t))) 303 (cond ((eq? result exp) (expand head exp head2)) 304 (else 305 (when ##sys#compiler-syntax-hook 306 (##sys#compiler-syntax-hook head result)) 307 (loop result)))))) 308 [else (expand head exp head2)] ) ) 309 (values exp #f) ) ) 310 (values exp #f) ) )) ) 310 311 311 312 (define ##sys#compiler-syntax-hook #f) 312 313 (define ##sys#enable-runtime-macros #f) … … 315 316 316 317 ;;; User-level macroexpansion 317 318 318 (define (expand exp #!optional (se (##sys#current-environment)) cs? )319 (define (expand exp #!optional (se (##sys#current-environment)) cs? (toplevel? #t)) 319 320 (let loop ((exp exp)) 320 (let-values (((exp2 m) (##sys#expand-0 exp se cs? )))321 (let-values (((exp2 m) (##sys#expand-0 exp se cs? toplevel?))) 321 322 (if m 322 323 (loop exp2) 323 324 exp2) ) ) ) … … 595 596 (else 596 597 (if (member (list head) vars) 597 598 (fini vars vals mvars body) 598 (let ((x2 (##sys#expand-0 x se cs? )))599 (let ((x2 (##sys#expand-0 x se cs? #f))) 599 600 (if (eq? x x2) 600 601 (fini vars vals mvars body) 601 602 (loop (cons x2 rest) … … 642 643 (define ##sys#syntax-error-culprit #f) 643 644 (define ##sys#syntax-context '()) 644 645 646 ;; Used to forbid definitions in expression contexts 647 (define ##sys#at-toplevel #t) 648 645 649 (define (syntax-error . args) 646 650 (apply ##sys#signal-hook #:syntax-error 647 651 (strip-syntax args))) … … 713 717 714 718 (define-constant +default-argument-count-limit+ 99999) 715 719 720 (define ##sys#check-toplevel-definition 721 (lambda (form exp) 722 (unless ##sys#at-toplevel 723 (let ((ln (get-line-number exp)) 724 (msg "definition found in expression context")) 725 (##sys#syntax-error-hook 726 (if ln 727 (string-append "(" ln ") in `" (symbol->string form) "' - " msg) 728 (string-append "in `" (symbol->string form) "' - " msg)) 729 exp))))) 730 716 731 (define ##sys#check-syntax 717 732 (lambda (id exp pat #!optional culprit (se (##sys#current-environment))) 718 733 … … 1034 1049 '() 1035 1050 (##sys#er-transformer 1036 1051 (lambda (x r c) 1052 (##sys#check-toplevel-definition 'define x) 1037 1053 (##sys#check-syntax 'define x '(_ . #(_ 1))) 1038 1054 (let loop ((form x)) 1039 1055 (let ((head (cadr form)) -
tests/functor-tests.scm
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm index 3f0588b..5ef48bb 100644
a b 166 166 (import chicken X) 167 167 yibble) 168 168 169 ;; XXX This is somewhat iffy: functor instantiation results in a 170 ;; value! 169 171 (test-equal 170 172 "alternative functor instantiation syntax" 171 173 (module yabble = frob (import scheme) (define yibble 99))
