Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2025-02-01 07:57:49 +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
; returns a denotation. The denotation of an unbound identifier is
; its name (as a symbol). A bound identifier's denotation is its
; returns a denotation. The denotation of an identifier is its
; binding, which is a pair of the current value and the identifier's
; 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.
; <identifier> -> <symbol> | <thunk returning den>
; <denotation> -> <symbol> | <binding>
; <denotation> -> <binding>
; <binding> -> (<symbol> . <value>)
; <value> -> <special> | <core>
; <special> -> <builtin> | <transformer>
@ -236,12 +235,11 @@
; <transformer> -> <procedure of exp and env returning exp>
(define-inline (val-core? val) (pair? val))
(define-inline (val-special? val) (not (pair? val)))
(define-inline (binding? x) (pair? x))
(define-inline (make-binding s v) (cons s v))
(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-set-val! bnd val) (set-cdr! bnd val))
(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 (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 (add-binding key val env) ; adds as-is
@ -317,7 +314,7 @@
(define (xform-ref id env)
(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 ...")]
[else (binding-val den)])))
@ -329,7 +326,7 @@
(define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail)))
(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)]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
@ -340,7 +337,7 @@
(define (xform-set& tail env)
(if (list1? 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")]
[else (let ([val (binding-val den)])
(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
; returns a denotation. The denotation of an unbound identifier is
; its name (as a symbol). A bound identifier's denotation is its
; returns a denotation. The denotation of an identifier is its
; binding, which is a pair of the current value and the identifier's
; 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.
; <identifier> -> <symbol> | <thunk returning den>
; <denotation> -> <symbol> | <binding>
; <denotation> -> <binding>
; <binding> -> (<symbol> . <value>)
; <value> -> <special> | <core>
; <special> -> <builtin> | <transformer>
@ -201,14 +200,12 @@
; <transformer> -> <procedure of exp and env returning exp>
(define-syntax val-core? pair?)
(define (val-special? val) (not (pair? val)))
(define-syntax binding? pair?)
(define-syntax make-binding cons)
(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-set-val! set-cdr!)
(define-syntax find-top-binding assq)
(define (new-id den) (define p (list den)) (lambda () p))
(define (old-den id) (car (id)))
@ -216,7 +213,6 @@
(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 (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 (add-binding key val env) ; adds as-is
@ -243,14 +239,16 @@
(define (xform appos? sexp env)
(cond [(id? sexp)
(let ([hval (xform-ref sexp env)])
(cond [appos? hval]
(cond [appos? ; app position: anything goes
hval]
[(integrable? hval) ; integrable id-syntax
(list 'ref (integrable-global hval))]
[(procedure? hval) ; id-syntax
(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)]
[else hval]))]
[else ; core
hval]))]
[(not (pair? sexp))
(xform-quote (list sexp) env)]
[else
@ -281,7 +279,7 @@
(define (xform-ref id env)
(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 ...")]
[else (binding-val den)])))
@ -293,7 +291,7 @@
(define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail)))
(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)]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
@ -304,7 +302,7 @@
(define (xform-set& tail env)
(if (list1? 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")]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
@ -507,52 +505,6 @@
(apply x-error args)
(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

59
t.c
View file

@ -83,9 +83,6 @@ char *t_code[] = {
"A", "val-core?", "pair?",
"P", "val-special?",
"%1.0p~]1",
"A", "binding?", "pair?",
"A", "make-binding", "cons",
@ -93,14 +90,12 @@ char *t_code[] = {
"A", "binding-val", "cdr",
"P", "binding-special?",
"%1.0d,@(y12:val-special?)[11",
"%1.0dp~]1",
"A", "binding-sym", "car",
"A", "binding-set-val!", "set-cdr!",
"A", "find-top-binding", "assq",
"P", "new-id",
"%1,#0.1,l1.!0.0,&1{%0:0^]0}]2",
@ -116,9 +111,6 @@ char *t_code[] = {
"P", "den->sym",
"%1.0Y0?{.0]1}.0a]1",
"P", "empty-xenv",
"%1.0Y0?{.0]1}.0,@(y7:old-den)[11",
"P", "extend-xenv",
"%3.0,.3,.3,&3{%1.0,:0q?{:1]1}.0,:2[11}]3",
@ -157,8 +149,8 @@ char *t_code[] = {
"orm-call)[73",
"P", "xform-ref",
"%2${.2,.4[01},.0Y0?{.0,'(y3:ref),l2]3}'(y3:...),.1dq?{'(s19:improper u"
"se of ...),@(y7:x-error)[31}.0d]3",
"%2${.2,.4[01},.0Y0?{.0,'(s14:unexpected den),@(y7:x-error)[32}'(y3:..."
"),.1dq?{'(s19:improper use of ...),@(y7:x-error)[31}.0d]3",
"P", "xform-quote",
"%2${.2,@(y6:list1?)[01}?{${.2a,@(y17:xform-sexp->datum)[01},'(y5:quote"
@ -166,17 +158,18 @@ char *t_code[] = {
"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"
"ecial?)[01}?{.1,.1sd'(l1:y5:begin;)]4}.0d,'(y3:ref),.1aq?{.2,.1da,'(y4"
":set!),l3]5}'(s27:set! to non-identifier form),@(y7:x-error)[51}.0,'(y"
"4:set!)c,'(s18:improper set! form),@(y7:x-error)[22",
"rm)[03},${.3a,.5[01},.0Y0?{.0,'(s22:unexpected den in set!),@(y7:x-err"
"or)[42}${.2,@(y16:binding-special?)[01}?{.1,.1sd'(l1:y5:begin;)]4}.0d,"
"'(y3:ref),.1aq?{.2,.1da,'(y4:set!),l3]5}'(s27:set! to non-identifier f"
"orm),@(y7:x-error)[51}.0,'(y4:set!)c,'(s18:improper set! form),@(y7:x-"
"error)[22",
"P", "xform-set&",
"%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},.0Y0?{.0,'(y4:set&),l2]3}${.2,@("
"y16:binding-special?)[01}?{'(s22:set& of a non-variable),@(y7:x-error)"
"[31}.0d,'(y3:ref),.1aq?{.0da,'(y4:set&),l2]4}'(s22:set& of a non-varia"
"ble),@(y7:x-error)[41}.0,'(y4:set&)c,'(s18:improper set& form),@(y7:x-"
"error)[22",
"%2${.2,@(y6:list1?)[01}?{${.2a,.4[01},.0Y0?{.0,'(s22:unexpected den in"
" set&),@(y7:x-error)[32}${.2,@(y16:binding-special?)[01}?{'(s22:set& o"
"f a non-variable),@(y7:x-error)[31}.0d,'(y3:ref),.1aq?{.0da,'(y4:set&)"
",l2]4}'(s22:set& of a non-variable),@(y7:x-error)[41}.0,'(y4:set&)c,'("
"s18:improper set& form),@(y7:x-error)[22",
"P", "xform-if",
"%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"
"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*",
"%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}"