Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2025-01-21 19:27:27 +01:00
Code Issues Projects Releases Packages Wiki Activity

syntax-rules form built-in

Browse source
This commit is contained in:
ESL 2023-04-13 18:31:20 -04:00
parent 72f51c06c5
commit 2c9383768e
4 changed files with 3758 additions and 3832 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7341
k.c
View file

File diff suppressed because it is too large Load diff

94
src/k.sf
View file

@ -293,12 +293,13 @@
[(if) (xform-if tail env)]
[(lambda) (xform-lambda tail env)]
[(lambda*) (xform-lambda* tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
[(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(syntax-rules) (xform-syntax-rules tail env)]
[(syntax-length) (xform-syntax-length tail env)]
[(syntax-error) (xform-syntax-error tail env)]
[else (if (integrable? hval)
@ -324,17 +325,6 @@
(list 'quote (xform-sexp->datum (car tail)))
(x-error "improper quote form" (cons 'quote tail))))
(define (xform-syntax-length tail env)
(if (and (list1? tail) (list? (car tail)))
(list 'quote (length (car tail)))
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
(define (xform-syntax-error tail env)
(let ([args (map xform-sexp->datum tail)])
(if (and (list1+? args) (string? (car args)))
(apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
(define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
@ -425,21 +415,6 @@
tail))
(x-error "improper lambda* form" (cons 'lambda* tail))))
(define (xform-syntax-lambda tail env)
(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 ...)
(lambda (use useenv)
(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))
(loop (cdr vars) (cdr exps)
(add-binding (car vars)
(xform #t (car exps) useenv) env))))
(x-error "invalif syntax-lambda application" use))))
(x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
(define (xform-letcc tail env)
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
@ -533,6 +508,40 @@
(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)
(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 ...)
(lambda (use useenv)
(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))
(loop (cdr vars) (cdr exps)
(add-binding (car vars)
(xform #t (car exps) useenv) env))))
(x-error "invalif syntax-lambda application" use))))
(x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
(define (xform-syntax-rules tail env)
(cond [(and (list2+? tail) (id? (car tail)) (andmap id? (cadr tail)))
(syntax-rules* env (car tail) (cadr tail) (cddr tail))]
[(and (list1+? tail) (andmap id? (car tail)))
(syntax-rules* env #f (car tail) (cdr tail))]
[else
(x-error "improper syntax-rules form" (cons 'syntax-rules tail))]))
(define (xform-syntax-length tail env)
(if (and (list1? tail) (list? (car tail)))
(list 'quote (length (car tail)))
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
(define (xform-syntax-error tail env)
(let ([args (map xform-sexp->datum tail)])
(if (and (list1+? args) (string? (car args)))
(apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
; ellipsis denotation is used for comparisons only
@ -550,6 +559,7 @@
(make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*)
(make-binding 'syntax-lambda 'syntax-lambda)
(make-binding 'syntax-rules 'syntax-rules)
(make-binding 'syntax-length 'syntax-length)
(make-binding 'syntax-error 'syntax-error)
(make-binding 'letcc 'letcc)
@ -576,16 +586,12 @@
(define (install-transformer! s t)
(binding-set-val! (top-transformer-env s) t))
(define (install-transformer-rules! s ell lits rules)
(install-transformer! s
(syntax-rules* top-transformer-env ell lits rules)))
(define (transform appos? sexp . optenv)
; (gensym #f) ; reset gs counter to make results reproducible
(xform appos? sexp (if (null? optenv) top-transformer-env (car optenv))))
; 'syntax-rules' transformer produces another transformer from the rules
; make transformer procedure from the rules
(define (syntax-rules* mac-env ellipsis pat-literals rules)
(define (pat-literal? id) (memq id pat-literals))
@ -702,37 +708,15 @@
(lambda (bindings) (expand-template pat tmpl bindings))]
[else (loop (cdr rules))])))))
(install-transformer! 'syntax-rules
(lambda (sexp env)
(define syntax-id (new-id (make-binding 'syntax 'syntax)))
; sexp can be either
(if (id? (cadr sexp))
; (_ ellipsis (litname ...) . rules)
(list syntax-id (syntax-rules* env (cadr sexp) (caddr sexp) (cdddr sexp)))
; or (_ (litname ...) . rules)
(list syntax-id (syntax-rules* env #f (cadr sexp) (cddr sexp))))))
;---------------------------------------------------------------------------------------------
; Runtime
; Runtime globals
;---------------------------------------------------------------------------------------------
(%localdef "#include \"i.h\"")
(define *globals* '())
(define global-location
(lambda (sym)
(let ([p (assq sym *globals*)])
(if (pair? p)
(cdr p)
(let ([loc (box 'undefined)])
(set! *globals* (cons (cons sym loc) *globals*))
loc)))))
(define-syntax index-global unbox)
(define-syntax index-set-global! set-box!)
(define *dynamic-state* (list #f)) ; for dynamic-wind
(define *current-input* #f)

76
src/t.scm
View file

@ -257,12 +257,13 @@
[(if) (xform-if tail env)]
[(lambda) (xform-lambda tail env)]
[(lambda*) (xform-lambda* tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
[(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(syntax-rules) (xform-syntax-rules tail env)]
[(syntax-length) (xform-syntax-length tail env)]
[(syntax-error) (xform-syntax-error tail env)]
[else (if (integrable? hval)
@ -288,17 +289,6 @@
(list 'quote (xform-sexp->datum (car tail)))
(x-error "improper quote form" (cons 'quote tail))))
(define (xform-syntax-length tail env)
(if (and (list1? tail) (list? (car tail)))
(list 'quote (length (car tail)))
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
(define (xform-syntax-error tail env)
(let ([args (map xform-sexp->datum tail)])
(if (and (list1+? args) (string? (car args)))
(apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
(define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
@ -389,21 +379,6 @@
tail))
(x-error "improper lambda* form" (cons 'lambda* tail))))
(define (xform-syntax-lambda tail env)
(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 ...)
(lambda (use useenv)
(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))
(loop (cdr vars) (cdr exps)
(add-binding (car vars)
(xform #t (car exps) useenv) env))))
(x-error "invalif syntax-lambda application" use))))
(x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
(define (xform-letcc tail env)
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
@ -497,6 +472,40 @@
(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)
(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 ...)
(lambda (use useenv)
(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))
(loop (cdr vars) (cdr exps)
(add-binding (car vars)
(xform #t (car exps) useenv) env))))
(x-error "invalif syntax-lambda application" use))))
(x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
(define (xform-syntax-rules tail env)
(cond [(and (list2+? tail) (id? (car tail)) (andmap id? (cadr tail)))
(syntax-rules* env (car tail) (cadr tail) (cddr tail))]
[(and (list1+? tail) (andmap id? (car tail)))
(syntax-rules* env #f (car tail) (cdr tail))]
[else
(x-error "improper syntax-rules form" (cons 'syntax-rules tail))]))
(define (xform-syntax-length tail env)
(if (and (list1? tail) (list? (car tail)))
(list 'quote (length (car tail)))
(x-error "improper syntax-length form" (cons 'syntax-length tail))))
(define (xform-syntax-error tail env)
(let ([args (map xform-sexp->datum tail)])
(if (and (list1+? args) (string? (car args)))
(apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail)))))
; ellipsis denotation is used for comparisons only
@ -514,6 +523,7 @@
(make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*)
(make-binding 'syntax-lambda 'syntax-lambda)
(make-binding 'syntax-rules 'syntax-rules)
(make-binding 'syntax-length 'syntax-length)
(make-binding 'syntax-error 'syntax-error)
(make-binding 'letcc 'letcc)
@ -549,7 +559,7 @@
(xform appos? sexp (if (null? optenv) top-transformer-env (car optenv))))
; 'syntax-rules' transformer produces another transformer from the rules
; make transformer procedure from the rules
(define (syntax-rules* mac-env ellipsis pat-literals rules)
(define (pat-literal? id) (memq id pat-literals))
@ -666,16 +676,6 @@
(lambda (bindings) (expand-template pat tmpl bindings))]
[else (loop (cdr rules))])))))
(install-transformer! 'syntax-rules
(lambda (sexp env)
(define syntax-id (new-id (make-binding 'syntax 'syntax)))
; sexp can be either
(if (id? (cadr sexp))
; (_ ellipsis (litname ...) . rules)
(list syntax-id (syntax-rules* env (cadr sexp) (caddr sexp) (cdddr sexp)))
; or (_ (litname ...) . rules)
(list syntax-id (syntax-rules* env #f (cadr sexp) (cddr sexp))))))
; Remaining transformers are made with the help of syntax-rules*
; NB: order of installation is important -- each transformer can

79
t.c
View file

@ -140,15 +140,16 @@ char *t_code[] = {
"?{.6,.3,@(y10:xform-set!)[72}'(y4:set&),.1v?{.6,.3,@(y10:xform-set&)[7"
"2}'(y5:begin),.1v?{.6,.3,@(y11:xform-begin)[72}'(y2:if),.1v?{.6,.3,@(y"
"8:xform-if)[72}'(y6:lambda),.1v?{.6,.3,@(y12:xform-lambda)[72}'(y7:lam"
"bda*),.1v?{.6,.3,@(y13:xform-lambda*)[72}'(y13:syntax-lambda),.1v?{.6,"
".3,@(y19:xform-syntax-lambda)[72}'(y5:letcc),.1v?{.6,.3,@(y11:xform-le"
"tcc)[72}'(y6:withcc),.1v?{.6,.3,@(y12:xform-withcc)[72}'(y4:body),.1v?"
"{.6,.3,@(y10:xform-body)[72}'(y6:define),.1v?{.6,.3,@(y12:xform-define"
")[72}'(y13:define-syntax),.1v?{.6,.3,@(y19:xform-define-syntax)[72}'(y"
"13:syntax-length),.1v?{.6,.3,@(y19:xform-syntax-length)[72}'(y12:synta"
"x-error),.1v?{.6,.3,@(y18:xform-syntax-error)[72}.1U0?{.6,.3,.3,@(y16:"
"xform-integrable)[73}.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,."
"3,@(y10:xform-call)[73",
"bda*),.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:bo"
"dy),.1v?{.6,.3,@(y10:xform-body)[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",
"P", "xform-sexp->datum",
"%1.0,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:id->sym)[11}.0p?{${.2d,:0^"
@ -162,15 +163,6 @@ char *t_code[] = {
"%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
"),l2]2}.0,'(y5:quote)c,'(s19:improper quote form),@(y7:x-error)[22",
"P", "xform-syntax-length",
"%2${.2,@(y6:list1?)[01}?{.0aL0}{f}?{.0ag,'(y5:quote),l2]2}.0,'(y13:syn"
"tax-length)c,'(s27:improper syntax-length form),@(y7:x-error)[22",
"P", "xform-syntax-error",
"%2${.2,@(y17:xform-sexp->datum),@(y5:%25map1)[02},${.2,@(y7:list1+?)[0"
"1}?{.0aS0}{f}?{.0,@(y7:x-error),@(y13:apply-to-list)[32}.1,'(y12:synta"
"x-error)c,'(s26:improper syntax-error form),@(y7:x-error)[32",
"P", "xform-set!",
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo"
"rm)[03},${.3a,.5[01},.0Y0?{.1,.1,'(y4:set!),l3]4}${.2,@(y16:binding-sp"
@ -229,15 +221,6 @@ char *t_code[] = {
"proper lambda* clause),@(y7:x-error)[12},@(y5:%25map1)[02},'(y7:lambda"
"*)c]2}.0,'(y7:lambda*)c,'(s21:improper lambda* 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,@(y11:add-binding)[03},.2d,.2d,:1^["
"33}.!0.0^_1[23}.0,'(s33:invalif syntax-lambda application),@(y7:x-erro"
"r)[22}]5}.0,'(y13:syntax-lambda)c,'(s27:improper syntax-lambda body),@"
"(y7:x-error)[22",
"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,@(y7:add-var)[03},.5d,@(y10:xf"
@ -293,6 +276,31 @@ char *t_code[] = {
"rm)[03},${.3a,@(y7:id->sym)[01},'(y13:define-syntax),l3]2}.0,'(y13:def"
"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,@(y11:add-binding)[03},.2d,.2d,:1^["
"33}.!0.0^_1[23}.0,'(s33:invalif syntax-lambda application),@(y7:x-erro"
"r)[22}]5}.0,'(y13:syntax-lambda)c,'(s27:improper syntax-lambda body),@"
"(y7:x-error)[22",
"P", "xform-syntax-rules",
"%2${.2,@(y7:list2+?)[01}?{${.2a,@(y3:id?)[01}?{${.2da,@(y3:id?),@(y6:a"
"ndmap)[02}}{f}}{f}?{.0dd,.1da,.2a,.4,@(y13:syntax-rules*)[24}${.2,@(y7"
":list1+?)[01}?{${.2a,@(y3:id?),@(y6:andmap)[02}}{f}?{.0d,.1a,f,.4,@(y1"
"3:syntax-rules*)[24}.0,'(y12:syntax-rules)c,'(s26:improper syntax-rule"
"s form),@(y7:x-error)[22",
"P", "xform-syntax-length",
"%2${.2,@(y6:list1?)[01}?{.0aL0}{f}?{.0ag,'(y5:quote),l2]2}.0,'(y13:syn"
"tax-length)c,'(s27:improper syntax-length form),@(y7:x-error)[22",
"P", "xform-syntax-error",
"%2${.2,@(y17:xform-sexp->datum),@(y5:%25map1)[02},${.2,@(y7:list1+?)[0"
"1}?{.0aS0}{f}?{.0,@(y7:x-error),@(y13:apply-to-list)[32}.1,'(y12:synta"
"x-error)c,'(s26:improper syntax-error form),@(y7:x-error)[32",
"C", 0,
"&0{%2.0,'(s19:improper use of ...),@(y7:x-error)[22},'(y3:...)c@!(y30:"
"denotation-of-default-ellipsis)",
@ -301,11 +309,12 @@ char *t_code[] = {
"@(y30:denotation-of-default-ellipsis),'(y4:body),'(y4:body)c,'(y2:if),"
"'(y2:if)c,'(y5:begin),'(y5:begin)c,'(y6:withcc),'(y6:withcc)c,'(y5:let"
"cc),'(y5:letcc)c,'(y12:syntax-error),'(y12:syntax-error)c,'(y13:syntax"
"-length),'(y13:syntax-length)c,'(y13:syntax-lambda),'(y13:syntax-lambd"
"a)c,'(y7:lambda*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&)"
",'(y4:set&)c,'(y4:set!),'(y4:set!)c,'(y5:quote),'(y5:quote)c,'(y13:def"
"ine-syntax),'(y13:define-syntax)c,'(y6:define),'(y6:define)c,'(y6:synt"
"ax),'(y6:syntax)c,l(i17)@!(y14:*transformers*)",
"-length),'(y13:syntax-length)c,'(y12:syntax-rules),'(y12:syntax-rules)"
"c,'(y13:syntax-lambda),'(y13:syntax-lambda)c,'(y7:lambda*),'(y7:lambda"
"*)c,'(y6:lambda),'(y6:lambda)c,'(y4:set&),'(y4:set&)c,'(y4:set!),'(y4:"
"set!)c,'(y5:quote),'(y5:quote)c,'(y13:define-syntax),'(y13:define-synt"
"ax)c,'(y6:define),'(y6:define)c,'(y6:syntax),'(y6:syntax)c,l(i18)@!(y1"
"4:*transformers*)",
"P", "top-transformer-env",
"%1@(y14:*transformers*),.1A3,.0p?{.0d,.0p?{'(y12:syntax-rules),.1aq}{f"
@ -353,12 +362,6 @@ char *t_code[] = {
"?{${:3,'(s14:invalid syntax),@(y7:x-error)[02}}.0a,.0a,.1da,${:2,:3,.5"
",:4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51}.!0.0^_1[21}](i11)",
"C", 0,
"${&0{%2,#0${'(y6:syntax),'(y6:syntax)c,@(y6:new-id)[01}.!0${.3da,@(y3:"
"id?)[01}?{${.3ddd,.4dda,.5da,.7,@(y13:syntax-rules*)[04},.1^,l2]3}${.3"
"dd,.4da,f,.7,@(y13:syntax-rules*)[04},.1^,l2]3},'(y12:syntax-rules),@("
"y20:install-transformer!)[02}",
"S", "install-sr-transformer!",
"l4:y12:syntax-rules;l2:y5:quote;y12:syntax-rules;;l2:l3:y1:_;l2:y5:quo"
"te;y4:name;;py12:syntax-rules;pl2:y3:lit;y3:...;;y5:rules;;;;l5:y26:in"