body/{let,letrec}-syntax can return macros!

body-based scope constructs with internal syntax-only definitions and single expression can allow this expression to be macro name or macro definition (if used in head position)
This commit is contained in:
ESL 2024-06-16 02:18:43 -04:00
parent 6cac06cdbb
commit 8cb032ab48
2 changed files with 82 additions and 76 deletions

View file

@ -325,11 +325,11 @@
[(lambda*) (xform-lambda* tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
[(body) (xform-body tail env appos?)]
[(begin) (xform-begin tail env)]
[(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env appos?)]
[(syntax-rules) (xform-syntax-rules tail env)]
[(syntax-length) (xform-syntax-length tail env)]
[(syntax-error) (xform-syntax-error tail env)]
@ -408,12 +408,12 @@
(let* ([var (car vars)] [nvar (gensym (id->sym var))])
(loop (cdr vars) (add-local-var var nvar ienv) (cons nvar ipars)))]
[(null? vars)
(list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))]
(list 'lambda (reverse ipars) (xform-body (cdr tail) ienv #f))]
[else ; improper
(let* ([var vars] [nvar (gensym (id->sym var))]
[ienv (add-local-var var nvar ienv)])
(list 'lambda (append (reverse ipars) nvar)
(xform-body (cdr tail) ienv)))]))
(xform-body (cdr tail) ienv #f)))]))
(x-error "improper lambda body" (cons 'lambda tail))))
(define (xform-lambda* tail env)
@ -435,16 +435,16 @@
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
(list 'letcc nvar
(xform-body (cdr tail) (add-local-var var nvar env))))
(xform-body (cdr tail) (add-local-var var nvar env) #f)))
(x-error "improper letcc form" (cons 'letcc tail))))
(define (xform-withcc tail env)
(if (list2+? tail)
(list 'withcc (xform #f (car tail) env)
(xform-body (cdr tail) env))
(xform-body (cdr tail) env) #f)
(x-error "improper withcc form" (cons 'withcc tail))))
(define (xform-body tail env)
(define (xform-body tail env appos?)
(cond
[(null? tail)
(list 'begin)]
@ -485,25 +485,30 @@
[else
(if (procedure? hval)
(loop env ids inits nids (cons (hval first env) rest))
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env))])))
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env)))]))
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env appos?))])))
(xform-labels (reverse ids) (reverse inits) (reverse nids) body env appos?)))]))
(define (xform-labels ids inits nids body env)
(define (xform-labels ids inits nids body env appos?)
(define no-defines? (andmap (lambda (nid) (eq? nid #t)) nids))
(let loop ([ids ids] [inits inits] [nids nids] [sets '()] [lids '()])
(cond [(null? ids)
(let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))]
[xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))])
(if (null? lids) xexp
(pair* 'call (list 'lambda (reverse lids) xexp)
(map (lambda (lid) '(begin)) lids))))]
[(not (car ids)) ; idless define
(cond [(null? ids)
(if (and no-defines? (list1? body))
; special case: expand body using current appos?
(xform appos? (car body) env)
; general case: produce expression
(let* ([xexps (append (reverse sets) (map (lambda (x) (xform #f x env)) body))]
[xexp (if (list1? xexps) (car xexps) (cons 'begin xexps))])
(if (null? lids) xexp
(pair* 'call (list 'lambda (reverse lids) xexp)
(map (lambda (lid) '(begin)) lids)))))]
[(not (car ids)) ; idless define, nid is #f
(loop (cdr ids) (cdr inits) (cdr nids)
(cons (xform #f (car inits) env) sets) lids)]
[(symbol? (car nids)) ; define
(loop (cdr ids) (cdr inits) (cdr nids)
(cons (xform-set! (list (car ids) (car inits)) env) sets)
(cons (car nids) lids))]
[else ; define-syntax
[else ; define-syntax, nid is #t
(location-set-val! (xenv-lookup env (car ids) 'set!) (xform #t (car inits) env))
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
@ -532,7 +537,7 @@
(list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
(x-error "improper define-syntax form" (cons 'define-syntax tail))))
(define (xform-syntax-lambda tail env)
(define (xform-syntax-lambda tail env appos?)
(if (and (list2+? tail) (andmap id? (car tail)))
(let ([vars (car tail)] [macenv env] [forms (cdr tail)])
; return a transformer that wraps xformed body in (syntax ...)
@ -541,7 +546,7 @@
(if (and (list1+? use) (fx=? (length vars) (length (cdr use))))
(let loop ([vars vars] [exps (cdr use)] [env macenv])
(if (null? vars)
(list 'syntax (xform-body forms env))
(list 'syntax (xform-body forms env appos?))
(loop (cdr vars) (cdr exps)
(extend-xenv-local (car vars)
(xform #t (car exps) useenv) env))))

113
t.c
View file

@ -176,15 +176,15 @@ char *t_code[] = {
"2}'(y2:if),.1v?{.6,.3,@(y8:xform-if)[72}'(y6:lambda),.1v?{.6,.3,@(y12:"
"xform-lambda)[72}'(y7:lambda*),.1v?{.6,.3,@(y13:xform-lambda*)[72}'(y5"
":letcc),.1v?{.6,.3,@(y11:xform-letcc)[72}'(y6:withcc),.1v?{.6,.3,@(y12"
":xform-withcc)[72}'(y4:body),.1v?{.6,.3,@(y10:xform-body)[72}'(y5:begi"
"n),.1v?{.6,.3,@(y11:xform-begin)[72}'(y6:define),.1v?{.6,.3,@(y12:xfor"
"m-define)[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syntax"
")[72}'(y13:syntax-lambda),.1v?{.6,.3,@(y19:xform-syntax-lambda)[72}'(y"
"12:syntax-rules),.1v?{.6,.3,@(y18:xform-syntax-rules)[72}'(y13:syntax-"
"length),.1v?{.6,.3,@(y19:xform-syntax-length)[72}'(y12:syntax-error),."
"1v?{.6,.3,@(y18:xform-syntax-error)[72}.1U0?{.6,.3,.3,@(y16:xform-inte"
"grable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,.3,@(y10:xf"
"orm-call)[73",
":xform-withcc)[72}'(y4:body),.1v?{.4,.7,.4,@(y10:xform-body)[73}'(y5:b"
"egin),.1v?{.6,.3,@(y11:xform-begin)[72}'(y6:define),.1v?{.6,.3,@(y12:x"
"form-define)[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syn"
"tax)[72}'(y13:syntax-lambda),.1v?{.4,.7,.4,@(y19:xform-syntax-lambda)["
"73}'(y12:syntax-rules),.1v?{.6,.3,@(y18:xform-syntax-rules)[72}'(y13:s"
"yntax-length),.1v?{.6,.3,@(y19:xform-syntax-length)[72}'(y12:syntax-er"
"ror),.1v?{.6,.3,@(y18:xform-syntax-error)[72}.1U0?{.6,.3,.3,@(y16:xfor"
"m-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,.3,@("
"y10:xform-call)[73",
"P", "xform-ref",
"%2${.2,.4,@(y8:xenv-ref)[02},'(y3:...),.1zq?{'(s19:improper use of ..."
@ -235,11 +235,11 @@ char *t_code[] = {
"P", "xform-lambda",
"%2${.2,@(y7:list1+?)[01}?{${.2a,@(y8:idslist?)[01}}{f}?{n,.2,.2a,,#0.4"
",.1,&2{%3.0p?{.0a,${${.4,@(y7:id->sym)[01},@(y6:gensym)[01},.4,.1c,${."
"6,.4,.6,@(y13:add-local-var)[03},.4d,:0^[53}.0u?{${.3,:1d,@(y10:xform-"
"body)[02},.3A8,'(y6:lambda),l3]3}.0,${${.4,@(y7:id->sym)[01},@(y6:gens"
"ym)[01},${.5,.3,.5,@(y13:add-local-var)[03},${.2,:1d,@(y10:xform-body)"
"[02},.2,.7A8L6,'(y6:lambda),l3]6}.!0.0^_1[23}.0,'(y6:lambda)c,'(s20:im"
"proper lambda body),@(y7:x-error)[22",
"6,.4,.6,@(y13:add-local-var)[03},.4d,:0^[53}.0u?{${f,.4,:1d,@(y10:xfor"
"m-body)[03},.3A8,'(y6:lambda),l3]3}.0,${${.4,@(y7:id->sym)[01},@(y6:ge"
"nsym)[01},${.5,.3,.5,@(y13:add-local-var)[03},${f,.3,:1d,@(y10:xform-b"
"ody)[03},.2,.7A8L6,'(y6:lambda),l3]6}.!0.0^_1[23}.0,'(y6:lambda)c,'(s2"
"0:improper lambda body),@(y7:x-error)[22",
"P", "xform-lambda*",
"%2.0L0?{${.2,.4,&1{%1${.2,@(y6:list2?)[01}?{${.2a,@(y6:list2?)[01}?{.0"
@ -250,47 +250,48 @@ char *t_code[] = {
"P", "xform-letcc",
"%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}}{f}?{.0a,${${.4,@(y7:id-"
">sym)[01},@(y6:gensym)[01},${${.7,.5,.7,@(y13:add-local-var)[03},.5d,@"
"(y10:xform-body)[02},.1,'(y5:letcc),l3]4}.0,'(y5:letcc)c,'(s19:imprope"
"r letcc form),@(y7:x-error)[22",
">sym)[01},@(y6:gensym)[01},${f,${.8,.6,.8,@(y13:add-local-var)[03},.6d"
",@(y10:xform-body)[03},.1,'(y5:letcc),l3]4}.0,'(y5:letcc)c,'(s19:impro"
"per letcc form),@(y7:x-error)[22",
"P", "xform-withcc",
"%2${.2,@(y7:list2+?)[01}?{${.3,.3d,@(y10:xform-body)[02},${.4,.4a,f,@("
"y5:xform)[03},'(y6:withcc),l3]2}.0,'(y6:withcc)c,'(s20:improper withcc"
" form),@(y7:x-error)[22",
"%2${.2,@(y7:list2+?)[01}?{f,${.4,.4d,@(y10:xform-body)[02},${.5,.5a,f,"
"@(y5:xform)[03},'(y6:withcc),l4]2}.0,'(y6:withcc)c,'(s20:improper with"
"cc form),@(y7:x-error)[22",
"P", "xform-body",
"%2.0u?{'(y5:begin),l1]2}${.2,@(y6:list1?)[01}?{.1,.1a,f,@(y5:xform)[23"
"}.0L0~?{.0,'(y4:body)c,'(s18:improper body form),@(y7:x-error)[22}.0,n"
",n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,.5a,.0a,.1d,${.6,.4,t,@(y5:xform"
")[03},.0,'(y5:begin),.1v?{.2L0?{.5,.3L6,.(i10),.(i10),.(i10),.(i10),:0"
"^[(i11)5}.4,'(s19:improper begin form),@(y7:x-error)[(i11)2}'(y6:defin"
"e),.1v?{${.4,@(y6:list2?)[01}?{.2au}{f}?{.2da,.6,.(i11),fc,.(i11),.3c,"
".(i11),fc,.(i11),:0^[(i12)5}${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01}"
"}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i11),.3,."
"6,@(y13:add-local-var)[03},.9,.(i14),.3c,.(i14),.5c,.(i14),.7c,.4,:0^["
"(i15)5}${.4,@(y7:list2+?)[01}?{.2ap?{${.4aa,@(y3:id?)[01}?{${.4ad,@(y8"
":idslist?)[01}}{f}}{f}}{f}?{.2aa,${f,'(y6:lambda)b,'(y6:lambda),@(y6:n"
"ew-id)[03},.4d,.5adc,.1c,${${.6,@(y7:id->sym)[01},@(y6:gensym)[01},${."
"(i12),.3,.7,@(y13:add-local-var)[03},.(i10),.(i15),.3c,.(i15),.5c,.(i1"
"5),.8c,.4,:0^[(i16)5}.4,'(s20:improper define form),@(y7:x-error)[(i11"
")2}'(y13:define-syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)[01"
"}}{f}?{.2a,.3da,${.(i10),'(l1:y9:undefined;),.5,@(y17:extend-xenv-loca"
"l)[03},.8,.(i13),tc,.(i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:impro"
"per define-syntax form),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02}c,"
".(i10),.(i10),.(i10),.(i10),:0^[(i11)5}.6,.(i11),.(i11)A8,.(i11)A8,.(i"
"11)A8,@(y12:xform-labels)[(i11)5}.0,.5,.5A8,.5A8,.5A8,@(y12:xform-labe"
"ls)[55}.!0.0^_1[25",
"%3.0u?{'(y5:begin),l1]3}${.2,@(y6:list1?)[01}?{.1,.1a,f,@(y5:xform)[33"
"}.0L0~?{.0,'(y4:body)c,'(s18:improper body form),@(y7:x-error)[32}.0,n"
",n,n,.5,,#0.8,.1,&2{%5.4p?{.4ap}{f}?{.4d,.5a,.0a,.1d,${.6,.4,t,@(y5:xf"
"orm)[03},.0,'(y5:begin),.1v?{.2L0?{.5,.3L6,.(i10),.(i10),.(i10),.(i10)"
",:0^[(i11)5}.4,'(s19:improper begin form),@(y7:x-error)[(i11)2}'(y6:de"
"fine),.1v?{${.4,@(y6:list2?)[01}?{.2au}{f}?{.2da,.6,.(i11),fc,.(i11),."
"3c,.(i11),fc,.(i11),:0^[(i12)5}${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)["
"01}}{f}?{.2a,.3da,${${.5,@(y7:id->sym)[01},@(y6:gensym)[01},${.(i11),."
"3,.6,@(y13:add-local-var)[03},.9,.(i14),.3c,.(i14),.5c,.(i14),.7c,.4,:"
"0^[(i15)5}${.4,@(y7:list2+?)[01}?{.2ap?{${.4aa,@(y3:id?)[01}?{${.4ad,@"
"(y8:idslist?)[01}}{f}}{f}}{f}?{.2aa,${f,'(y6:lambda)b,'(y6:lambda),@(y"
"6:new-id)[03},.4d,.5adc,.1c,${${.6,@(y7:id->sym)[01},@(y6:gensym)[01},"
"${.(i12),.3,.7,@(y13:add-local-var)[03},.(i10),.(i15),.3c,.(i15),.5c,."
"(i15),.8c,.4,:0^[(i16)5}.4,'(s20:improper define form),@(y7:x-error)[("
"i11)2}'(y13:define-syntax),.1v?{${.4,@(y6:list2?)[01}?{${.4a,@(y3:id?)"
"[01}}{f}?{.2a,.3da,${.(i10),'(l1:y9:undefined;),.5,@(y17:extend-xenv-l"
"ocal)[03},.8,.(i13),tc,.(i13),.4c,.(i13),.6c,.4,:0^[(i14)5}.4,'(s27:im"
"proper define-syntax form),@(y7:x-error)[(i11)2}.1K0?{.5,${.9,.8,.6[02"
"}c,.(i10),.(i10),.(i10),.(i10),:0^[(i11)5}:1,.7,.(i12),.(i12)A8,.(i12)"
"A8,.(i12)A8,@(y12:xform-labels)[(i11)6}:1,.1,.6,.6A8,.6A8,.6A8,@(y12:x"
"form-labels)[56}.!0.0^_1[35",
"P", "xform-labels",
"%5n,n,.4,.4,.4,,#0.0,.(i11),.(i11),&3{%5.0u?{${:0,:1,&1{%1:0,.1,f,@(y5"
":xform)[13},@(y5:%25map1)[02},.4A8L6,${.2,@(y6:list1?)[01}?{.0a}{.0,'("
"y5:begin)c},.6u?{.0]7}${.8,&0{%1'(l1:y5:begin;)]1},@(y5:%25map1)[02},."
"1,.8A8,'(y6:lambda),l3,'(y4:call),@(y5:pair*)[73}.0a~?{.4,.4,${:1,.6a,"
"f,@(y5:xform)[03}c,.4d,.4d,.4d,:2^[55}.2aY0?{.4,.3ac,.4,${:1,.6a,.6a,l"
"2,@(y10:xform-set!)[02}c,.4d,.4d,.4d,:2^[55}${:1,.4a,t,@(y5:xform)[03}"
",${'(y4:set!),.4a,:1,@(y11:xenv-lookup)[03}sz.4,.4,.4d,.4d,.4d,:2^[55}"
".!0.0^_1[55",
"%6,#0${.5,&0{%1t,.1q]1},@(y6:andmap)[02}.!0n,n,.5,.5,.5,,#0.0,.(i12),."
"8,.(i15),.(i14),&5{%5.0u?{:2^?{${:0,@(y6:list1?)[01}}{f}?{:3,:0a,:1,@("
"y5:xform)[53}${:0,:3,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.4"
"A8L6,${.2,@(y6:list1?)[01}?{.0a}{.0,'(y5:begin)c},.6u?{.0]7}${.8,&0{%1"
"'(l1:y5:begin;)]1},@(y5:%25map1)[02},.1,.8A8,'(y6:lambda),l3,'(y4:call"
"),@(y5:pair*)[73}.0a~?{.4,.4,${:3,.6a,f,@(y5:xform)[03}c,.4d,.4d,.4d,:"
"4^[55}.2aY0?{.4,.3ac,.4,${:3,.6a,.6a,l2,@(y10:xform-set!)[02}c,.4d,.4d"
",.4d,:4^[55}${:3,.4a,t,@(y5:xform)[03},${'(y4:set!),.4a,:3,@(y11:xenv-"
"lookup)[03}sz.4,.4,.4d,.4d,.4d,:4^[55}.!0.0^_1[75",
"P", "xform-begin",
"%2.0L0?{${.2,.4,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.0p?{.0"
@ -311,13 +312,13 @@ char *t_code[] = {
"ine-syntax)c,'(s27:improper define-syntax form),@(y7:x-error)[22",
"P", "xform-syntax-lambda",
"%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?),@(y6:andmap)[02}}{f}?{.0d,.2"
",.2a,.2,.1,.3,&3{%2${.2,@(y7:list1+?)[01}?{.0dg,:1gI=}{f}?{:0,.1d,:1,,"
"#0.5,.1,:2,&3{%3.0u?{${.4,:0,@(y10:xform-body)[02},'(y6:syntax),l2]3}$"
"{.4,${:2,.7a,t,@(y5:xform)[03},.4a,@(y17:extend-xenv-local)[03},.2d,.2"
"d,:1^[33}.!0.0^_1[23}.0,'(s33:invalid syntax-lambda application),@(y7:"
"x-error)[22}]5}.0,'(y13:syntax-lambda)c,'(s27:improper syntax-lambda b"
"ody),@(y7:x-error)[22",
"%3${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?),@(y6:andmap)[02}}{f}?{.0d,.2"
",.2a,.5,.3,.2,.4,&4{%2${.2,@(y7:list1+?)[01}?{.0dg,:1gI=}{f}?{:0,.1d,:"
"1,,#0.5,.1,:3,:2,&4{%3.0u?{${:1,.5,:0,@(y10:xform-body)[03},'(y6:synta"
"x),l2]3}${.4,${:3,.7a,t,@(y5:xform)[03},.4a,@(y17:extend-xenv-local)[0"
"3},.2d,.2d,:2^[33}.!0.0^_1[23}.0,'(s33:invalid syntax-lambda applicati"
"on),@(y7:x-error)[22}]6}.0,'(y13:syntax-lambda)c,'(s27:improper syntax"
"-lambda body),@(y7:x-error)[32",
"P", "xform-syntax-rules",
"%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}?{${.2da,@(y3:id?),@(y6:a"