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

no symbolic denotations; minor cleanup

Browse source
This commit is contained in:
ESL 2023-04-15 17:41:28 -04:00
parent 5d4078b173
commit c10c65e90c
4 changed files with 2852 additions and 3019 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5727
k.c
View file

File diff suppressed because it is too large Load diff

15
src/k.sf
View file

@ -217,8 +217,7 @@
;--------------------------------------------------------------------------------------------- ;---------------------------------------------------------------------------------------------
; An environment is a procedure that accepts any identifier and ; An environment is a procedure that accepts any identifier and
; returns a denotation. The denotation of an unbound identifier is ; returns a denotation. The denotation of an identifier is its
; its name (as a symbol). A bound identifier's denotation is its
; binding, which is a pair of the current value and the identifier's ; binding, which is a pair of the current value and the identifier's
; name (needed by quote). Biding's value can be changed later. ; name (needed by quote). Biding's value can be changed later.
@ -226,7 +225,7 @@
; that takes two arguments: a macro use and the environment of the macro use. ; that takes two arguments: a macro use and the environment of the macro use.
; <identifier> -> <symbol> | <thunk returning den> ; <identifier> -> <symbol> | <thunk returning den>
; <denotation> -> <symbol> | <binding> ; <denotation> -> <binding>
; <binding> -> (<symbol> . <value>) ; <binding> -> (<symbol> . <value>)
; <value> -> <special> | <core> ; <value> -> <special> | <core>
; <special> -> <builtin> | <transformer> ; <special> -> <builtin> | <transformer>
@ -236,12 +235,11 @@
; <transformer> -> <procedure of exp and env returning exp> ; <transformer> -> <procedure of exp and env returning exp>
(define-inline (val-core? val) (pair? val)) (define-inline (val-core? val) (pair? val))
(define-inline (val-special? val) (not (pair? val)))
(define-inline (binding? x) (pair? x)) (define-inline (binding? x) (pair? x))
(define-inline (make-binding s v) (cons s v)) (define-inline (make-binding s v) (cons s v))
(define-inline (binding-val bnd) (cdr bnd)) (define-inline (binding-val bnd) (cdr bnd))
(define-inline (binding-special? bnd) (val-special? (cdr bnd))) (define-inline (binding-special? bnd) (not (pair? (cdr bnd))))
(define-inline (binding-sym bnd) (car bnd)) (define-inline (binding-sym bnd) (car bnd))
(define-inline (binding-set-val! bnd val) (set-cdr! bnd val)) (define-inline (binding-set-val! bnd val) (set-cdr! bnd val))
(define-inline (find-top-binding s blist) (assq s blist)) (define-inline (find-top-binding s blist) (assq s blist))
@ -252,7 +250,6 @@
(define (id->sym id) (if (symbol? id) id (den->sym (old-den id)))) (define (id->sym id) (if (symbol? id) id (den->sym (old-den id))))
(define (den->sym den) (if (symbol? den) den (binding-sym den))) (define (den->sym den) (if (symbol? den) den (binding-sym den)))
(define (empty-xenv id) (if (symbol? id) id (old-den id)))
(define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i)))) (define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i))))
(define (add-binding key val env) ; adds as-is (define (add-binding key val env) ; adds as-is
@ -317,7 +314,7 @@
(define (xform-ref id env) (define (xform-ref id env)
(let ([den (env id)]) (let ([den (env id)])
(cond [(symbol? den) (list 'ref den)] (cond [(symbol? den) (x-error "unexpected den" den)] ;(list 'ref den)
[(eq? (binding-val den) '...) (x-error "improper use of ...")] [(eq? (binding-val den) '...) (x-error "improper use of ...")]
[else (binding-val den)]))) [else (binding-val den)])))
@ -329,7 +326,7 @@
(define (xform-set! tail env) (define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)]) (let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
(cond [(symbol? den) (list 'set! den xexp)] (cond [(symbol? den) (x-error "unexpected den in set!" den)] ;(list 'set! den xexp)
[(binding-special? den) (binding-set-val! den xexp) '(begin)] [(binding-special? den) (binding-set-val! den xexp) '(begin)]
[else (let ([val (binding-val den)]) [else (let ([val (binding-val den)])
(if (eq? (car val) 'ref) (if (eq? (car val) 'ref)
@ -340,7 +337,7 @@
(define (xform-set& tail env) (define (xform-set& tail env)
(if (list1? tail) (if (list1? tail)
(let ([den (env (car tail))]) (let ([den (env (car tail))])
(cond [(symbol? den) (list 'set& den)] (cond [(symbol? den) (x-error "unexpected den in set&" den)] ;(list 'set& den)
[(binding-special? den) (x-error "set& of a non-variable")] [(binding-special? den) (x-error "set& of a non-variable")]
[else (let ([val (binding-val den)]) [else (let ([val (binding-val den)])
(if (eq? (car val) 'ref) (if (eq? (car val) 'ref)

70
src/t.scm
View file

@ -182,8 +182,7 @@
;--------------------------------------------------------------------------------------------- ;---------------------------------------------------------------------------------------------
; An environment is a procedure that accepts any identifier and ; An environment is a procedure that accepts any identifier and
; returns a denotation. The denotation of an unbound identifier is ; returns a denotation. The denotation of an identifier is its
; its name (as a symbol). A bound identifier's denotation is its
; binding, which is a pair of the current value and the identifier's ; binding, which is a pair of the current value and the identifier's
; name (needed by quote). Biding's value can be changed later. ; name (needed by quote). Biding's value can be changed later.
@ -191,7 +190,7 @@
; that takes two arguments: a macro use and the environment of the macro use. ; that takes two arguments: a macro use and the environment of the macro use.
; <identifier> -> <symbol> | <thunk returning den> ; <identifier> -> <symbol> | <thunk returning den>
; <denotation> -> <symbol> | <binding> ; <denotation> -> <binding>
; <binding> -> (<symbol> . <value>) ; <binding> -> (<symbol> . <value>)
; <value> -> <special> | <core> ; <value> -> <special> | <core>
; <special> -> <builtin> | <transformer> ; <special> -> <builtin> | <transformer>
@ -201,14 +200,12 @@
; <transformer> -> <procedure of exp and env returning exp> ; <transformer> -> <procedure of exp and env returning exp>
(define-syntax val-core? pair?) (define-syntax val-core? pair?)
(define (val-special? val) (not (pair? val)))
(define-syntax binding? pair?) (define-syntax binding? pair?)
(define-syntax make-binding cons) (define-syntax make-binding cons)
(define-syntax binding-val cdr) (define-syntax binding-val cdr)
(define (binding-special? bnd) (val-special? (cdr bnd))) (define (binding-special? bnd) (not (pair? (cdr bnd))))
(define-syntax binding-sym car) (define-syntax binding-sym car)
(define-syntax binding-set-val! set-cdr!) (define-syntax binding-set-val! set-cdr!)
(define-syntax find-top-binding assq)
(define (new-id den) (define p (list den)) (lambda () p)) (define (new-id den) (define p (list den)) (lambda () p))
(define (old-den id) (car (id))) (define (old-den id) (car (id)))
@ -216,7 +213,6 @@
(define (id->sym id) (if (symbol? id) id (den->sym (old-den id)))) (define (id->sym id) (if (symbol? id) id (den->sym (old-den id))))
(define (den->sym den) (if (symbol? den) den (binding-sym den))) (define (den->sym den) (if (symbol? den) den (binding-sym den)))
(define (empty-xenv id) (if (symbol? id) id (old-den id)))
(define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i)))) (define (extend-xenv env id bnd) (lambda (i) (if (eq? id i) bnd (env i))))
(define (add-binding key val env) ; adds as-is (define (add-binding key val env) ; adds as-is
@ -243,14 +239,16 @@
(define (xform appos? sexp env) (define (xform appos? sexp env)
(cond [(id? sexp) (cond [(id? sexp)
(let ([hval (xform-ref sexp env)]) (let ([hval (xform-ref sexp env)])
(cond [appos? hval] (cond [appos? ; app position: anything goes
hval]
[(integrable? hval) ; integrable id-syntax [(integrable? hval) ; integrable id-syntax
(list 'ref (integrable-global hval))] (list 'ref (integrable-global hval))]
[(procedure? hval) ; id-syntax [(procedure? hval) ; id-syntax
(xform appos? (hval sexp env) env)] (xform appos? (hval sexp env) env)]
[(not (pair? hval)) [(not (pair? hval)) ; special used out of context
(x-error "improper use of syntax form" hval)] (x-error "improper use of syntax form" hval)]
[else hval]))] [else ; core
hval]))]
[(not (pair? sexp)) [(not (pair? sexp))
(xform-quote (list sexp) env)] (xform-quote (list sexp) env)]
[else [else
@ -281,7 +279,7 @@
(define (xform-ref id env) (define (xform-ref id env)
(let ([den (env id)]) (let ([den (env id)])
(cond [(symbol? den) (list 'ref den)] (cond [(symbol? den) (x-error "unexpected den" den)] ;(list 'ref den)
[(eq? (binding-val den) '...) (x-error "improper use of ...")] [(eq? (binding-val den) '...) (x-error "improper use of ...")]
[else (binding-val den)]))) [else (binding-val den)])))
@ -293,7 +291,7 @@
(define (xform-set! tail env) (define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail))) (if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)]) (let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
(cond [(symbol? den) (list 'set! den xexp)] (cond [(symbol? den) (x-error "unexpected den in set!" den)] ;(list 'set! den xexp)
[(binding-special? den) (binding-set-val! den xexp) '(begin)] [(binding-special? den) (binding-set-val! den xexp) '(begin)]
[else (let ([val (binding-val den)]) [else (let ([val (binding-val den)])
(if (eq? (car val) 'ref) (if (eq? (car val) 'ref)
@ -304,7 +302,7 @@
(define (xform-set& tail env) (define (xform-set& tail env)
(if (list1? tail) (if (list1? tail)
(let ([den (env (car tail))]) (let ([den (env (car tail))])
(cond [(symbol? den) (list 'set& den)] (cond [(symbol? den) (x-error "unexpected den in set&" den)] ;(list 'set& den)
[(binding-special? den) (x-error "set& of a non-variable")] [(binding-special? den) (x-error "set& of a non-variable")]
[else (let ([val (binding-val den)]) [else (let ([val (binding-val den)])
(if (eq? (car val) 'ref) (if (eq? (car val) 'ref)
@ -507,52 +505,6 @@
(apply x-error args) (apply x-error args)
(x-error "improper syntax-error form" (cons 'syntax-error tail))))) (x-error "improper syntax-error form" (cons 'syntax-error tail)))))
(define *transformers*
(list
(make-binding 'syntax 'syntax)
(make-binding 'quote 'quote)
(make-binding 'set! 'set!)
(make-binding 'set& 'set&)
(make-binding 'if 'if)
(make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*)
(make-binding 'letcc 'letcc)
(make-binding 'withcc 'withcc)
(make-binding 'body 'body)
(make-binding 'begin 'begin)
(make-binding 'define 'define)
(make-binding 'define-syntax 'define-syntax)
(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 '... '...)))
(define (top-transformer-env id)
(let ([bnd (find-top-binding id *transformers*)])
(cond [(binding? bnd)
; special case: syntax-rules in sexp form (left by init)
(let ([val (binding-val bnd)])
(if (and (pair? val) (eq? (car val) 'syntax-rules))
(binding-set-val! bnd (transform #t val))))
bnd]
[(symbol? id)
(let ([bnd (make-binding id (or (lookup-integrable id) (list 'ref id)))])
(set! *transformers* (cons bnd *transformers*))
bnd)]
[else (old-den id)])))
(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))))
; make transformer procedure from the rules ; make transformer procedure from the rules

59
t.c
View file

@ -83,9 +83,6 @@ char *t_code[] = {
"A", "val-core?", "pair?", "A", "val-core?", "pair?",
"P", "val-special?",
"%1.0p~]1",
"A", "binding?", "pair?", "A", "binding?", "pair?",
"A", "make-binding", "cons", "A", "make-binding", "cons",
@ -93,14 +90,12 @@ char *t_code[] = {
"A", "binding-val", "cdr", "A", "binding-val", "cdr",
"P", "binding-special?", "P", "binding-special?",
"%1.0d,@(y12:val-special?)[11", "%1.0dp~]1",
"A", "binding-sym", "car", "A", "binding-sym", "car",
"A", "binding-set-val!", "set-cdr!", "A", "binding-set-val!", "set-cdr!",
"A", "find-top-binding", "assq",
"P", "new-id", "P", "new-id",
"%1,#0.1,l1.!0.0,&1{%0:0^]0}]2", "%1,#0.1,l1.!0.0,&1{%0:0^]0}]2",
@ -116,9 +111,6 @@ char *t_code[] = {
"P", "den->sym", "P", "den->sym",
"%1.0Y0?{.0]1}.0a]1", "%1.0Y0?{.0]1}.0a]1",
"P", "empty-xenv",
"%1.0Y0?{.0]1}.0,@(y7:old-den)[11",
"P", "extend-xenv", "P", "extend-xenv",
"%3.0,.3,.3,&3{%1.0,:0q?{:1]1}.0,:2[11}]3", "%3.0,.3,.3,&3{%1.0,:0q?{:1]1}.0,:2[11}]3",
@ -157,8 +149,8 @@ char *t_code[] = {
"orm-call)[73", "orm-call)[73",
"P", "xform-ref", "P", "xform-ref",
"%2${.2,.4[01},.0Y0?{.0,'(y3:ref),l2]3}'(y3:...),.1dq?{'(s19:improper u" "%2${.2,.4[01},.0Y0?{.0,'(s14:unexpected den),@(y7:x-error)[32}'(y3:..."
"se of ...),@(y7:x-error)[31}.0d]3", "),.1dq?{'(s19:improper use of ...),@(y7:x-error)[31}.0d]3",
"P", "xform-quote", "P", "xform-quote",
"%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote" "%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
@ -166,17 +158,18 @@ char *t_code[] = {
"P", "xform-set!", "P", "xform-set!",
"%2${.2,@(y6:list2?)[01}?{${.2a,@(y3:id?)[01}}{f}?{${.3,.3da,f,@(y5:xfo" "%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" "rm)[03},${.3a,.5[01},.0Y0?{.0,'(s22:unexpected den in set!),@(y7:x-err"
"ecial?)[01}?{.1,.1sd'(l1:y5:begin;)]4}.0d,'(y3:ref),.1aq?{.2,.1da,'(y4" "or)[42}${.2,@(y16:binding-special?)[01}?{.1,.1sd'(l1:y5:begin;)]4}.0d,"
":set!),l3]5}'(s27:set! to non-identifier form),@(y7:x-error)[51}.0,'(y" "'(y3:ref),.1aq?{.2,.1da,'(y4:set!),l3]5}'(s27:set! to non-identifier f"
"4:set!)c,'(s18:improper set! form),@(y7:x-error)[22", "orm),@(y7:x-error)[51}.0,'(y4:set!)c,'(s18:improper set! form),@(y7:x-"
"error)[22",
"P", "xform-set&", "P", "xform-set&",
"%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},.0Y0?{.0,'(y4:set&),l2]3}${.2,@(" "%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},.0Y0?{.0,'(s22:unexpected den in"
"y16:binding-special?)[01}?{'(s22:set& of a non-variable),@(y7:x-error)" " set&),@(y7:x-error)[32}${.2,@(y16:binding-special?)[01}?{'(s22:set& o"
"[31}.0d,'(y3:ref),.1aq?{.0da,'(y4:set&),l2]4}'(s22:set& of a non-varia" "f a non-variable),@(y7:x-error)[31}.0d,'(y3:ref),.1aq?{.0da,'(y4:set&)"
"ble),@(y7:x-error)[41}.0,'(y4:set&)c,'(s18:improper set& form),@(y7:x-" ",l2]4}'(s22:set& of a non-variable),@(y7:x-error)[41}.0,'(y4:set&)c,'("
"error)[22", "s18:improper set& form),@(y7:x-error)[22",
"P", "xform-if", "P", "xform-if",
"%2.0L0?{${.2,.4,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.0g,'2," "%2.0L0?{${.2,.4,&1{%1:0,.1,f,@(y5:xform)[13},@(y5:%25map1)[02},.0g,'2,"
@ -302,32 +295,6 @@ char *t_code[] = {
"1}?{.0aS0}{f}?{.0,@(y7:x-error),@(y13:apply-to-list)[32}.1,'(y12:synta" "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", "x-error)c,'(s26:improper syntax-error form),@(y7:x-error)[32",
"C", 0,
"'(y3:...),'(y3:...)c,'(y12:syntax-error),'(y12:syntax-error)c,'(y13:sy"
"ntax-length),'(y13:syntax-length)c,'(y12:syntax-rules),'(y12:syntax-ru"
"les)c,'(y13:syntax-lambda),'(y13:syntax-lambda)c,'(y13:define-syntax),"
"'(y13:define-syntax)c,'(y6:define),'(y6:define)c,'(y5:begin),'(y5:begi"
"n)c,'(y4:body),'(y4:body)c,'(y6:withcc),'(y6:withcc)c,'(y5:letcc),'(y5"
":letcc)c,'(y7:lambda*),'(y7:lambda*)c,'(y6:lambda),'(y6:lambda)c,'(y2:"
"if),'(y2:if)c,'(y4:set&),'(y4:set&)c,'(y4:set!),'(y4:set!)c,'(y5:quote"
"),'(y5:quote)c,'(y6:syntax),'(y6:syntax)c,l(i18)@!(y14:*transformers*)",
"P", "top-transformer-env",
"%1@(y14:*transformers*),.1A3,.0p?{.0d,.0p?{'(y12:syntax-rules),.1aq}{f"
"}?{${.2,t,@(y9:transform)[02},.2sd}_1.0]2}.1Y0?{.1U5,.0?{.0}{.2,'(y3:r"
"ef),l2}_1,.2c,@(y14:*transformers*),.1c@!(y14:*transformers*).0]3}.1,@"
"(y7:old-den)[21",
"P", "install-transformer!",
"%2.1,${.3,@(y19:top-transformer-env)[01}sd]2",
"P", "install-transformer-rules!",
"%4${.5,.5,.5,@(y19:top-transformer-env),@(y13:syntax-rules*)[04},.1,@("
"y20:install-transformer!)[42",
"P", "transform",
"%!2.0u?{@(y19:top-transformer-env)}{.0a},.3,.3,@(y5:xform)[33",
"P", "syntax-rules*", "P", "syntax-rules*",
"%4,,,,,,,,#0#1#2#3#4#5#6#7.(i10),&1{%1:0,.1A0]1}.!0.0,&1{%1${.2,:0^[01" "%4,,,,,,,,#0#1#2#3#4#5#6#7.(i10),&1{%1:0,.1A0]1}.!0.0,&1{%1${.2,:0^[01"
"}~]1}.!1.4,&1{%1.0p?{.0a,:0^[11}f]1}.!2&0{%1.0p?{'(y3:...),.1dq]1}f]1}" "}~]1}.!1.4,&1{%1.0p?{.0a,:0^[11}f]1}.!2&0{%1.0p?{'(y3:...),.1dq]1}f]1}"