mirror of
https://github.com/false-schemers/skint.git
synced 2025-01-21 19:27:27 +01:00
t.{scm,c}: compiler added
This commit is contained in:
ESL
parent
64405f85f6
commit
ebd93be256
2 changed files with 730 additions and 0 deletions
504
src/t.scm
504
src/t.scm
|
|
@ -620,6 +620,489 @@
|
||||||
[else (loop (cdr rules))])))))
|
[else (loop (cdr rules))])))))
|
||||||
|
|
||||||
|
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
; String representation of S-expressions and code arguments
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (write-serialized-char x port)
|
||||||
|
(cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char<? x #\space) (char>? x #\~))
|
||||||
|
(write-char #\% port)
|
||||||
|
(let ([s (fixnum->string (char->integer x) 16)])
|
||||||
|
(if (fx=? (string-length s) 1) (write-char #\0 port))
|
||||||
|
(write-string s port))]
|
||||||
|
[else (write-char x port)]))
|
||||||
|
|
||||||
|
(define (write-serialized-byte x port)
|
||||||
|
(let ([s (fixnum->string x 16)])
|
||||||
|
(if (fx=? (string-length s) 1) (write-char #\0 port))
|
||||||
|
(write-string s port)))
|
||||||
|
|
||||||
|
(define (write-serialized-size n port)
|
||||||
|
(write-string (fixnum->string n 10) port)
|
||||||
|
(write-char #\: port))
|
||||||
|
|
||||||
|
(define (write-serialized-element x port)
|
||||||
|
(write-serialized-sexp x port)
|
||||||
|
(write-char #\; port))
|
||||||
|
|
||||||
|
(define (write-serialized-sexp x port)
|
||||||
|
(cond [(eq? x #f)
|
||||||
|
(write-char #\f port)]
|
||||||
|
[(eq? x #t)
|
||||||
|
(write-char #\t port)]
|
||||||
|
[(eq? x '())
|
||||||
|
(write-char #\n port)]
|
||||||
|
[(char? x)
|
||||||
|
(write-char #\c port)
|
||||||
|
(write-serialized-char x port)]
|
||||||
|
[(number? x)
|
||||||
|
(write-char (if (exact? x) #\i #\j) port)
|
||||||
|
(write-string (number->string x 10) port)]
|
||||||
|
[(list? x)
|
||||||
|
(write-char #\l port)
|
||||||
|
(write-serialized-size (length x) port)
|
||||||
|
(do ([x x (cdr x)]) [(null? x)]
|
||||||
|
(write-serialized-element (car x) port))]
|
||||||
|
[(pair? x)
|
||||||
|
(write-char #\p port)
|
||||||
|
(write-serialized-element (car x) port)
|
||||||
|
(write-serialized-element (cdr x) port)]
|
||||||
|
[(vector? x)
|
||||||
|
(write-char #\v port)
|
||||||
|
(write-serialized-size (vector-length x) port)
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx=? i (vector-length x))]
|
||||||
|
(write-serialized-element (vector-ref x i) port))]
|
||||||
|
[(string? x)
|
||||||
|
(write-char #\s port)
|
||||||
|
(write-serialized-size (string-length x) port)
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))]
|
||||||
|
(write-serialized-char (string-ref x i) port))]
|
||||||
|
[(bytevector? x)
|
||||||
|
(write-char #\b port)
|
||||||
|
(write-serialized-size (bytevector-length x) port)
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx=? i (bytevector-length x))]
|
||||||
|
(write-serialized-byte (bytevector-u8-ref x i) port))]
|
||||||
|
[(symbol? x)
|
||||||
|
(write-char #\y port)
|
||||||
|
(let ([x (symbol->string x)])
|
||||||
|
(write-serialized-size (string-length x) port)
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))]
|
||||||
|
(write-serialized-char (string-ref x i) port)))]
|
||||||
|
[(box? x)
|
||||||
|
(write-char #\z port)
|
||||||
|
(write-serialized-element (unbox x) port)]
|
||||||
|
[else (c-error "cannot encode literal" x)]))
|
||||||
|
|
||||||
|
(define (write-serialized-arg arg port)
|
||||||
|
(if (and (number? arg) (exact? arg) (fx<=? 0 arg) (fx<=? arg 9))
|
||||||
|
(write-char (string-ref "0123456789" arg) port)
|
||||||
|
(begin (write-char #\( port)
|
||||||
|
(write-serialized-sexp arg port)
|
||||||
|
(write-char #\) port))))
|
||||||
|
|
||||||
|
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
; Compiler producing serialized code
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (c-error msg . args)
|
||||||
|
(error* (string-append "compiler: " msg) args))
|
||||||
|
|
||||||
|
(define find-free*
|
||||||
|
(lambda (x* b)
|
||||||
|
(if (null? x*)
|
||||||
|
'()
|
||||||
|
(set-union
|
||||||
|
(find-free (car x*) b)
|
||||||
|
(find-free* (cdr x*) b)))))
|
||||||
|
|
||||||
|
(define find-free
|
||||||
|
(lambda (x b)
|
||||||
|
(record-case x
|
||||||
|
[quote (obj)
|
||||||
|
'()]
|
||||||
|
[ref (id)
|
||||||
|
(if (set-member? id b) '() (list id))]
|
||||||
|
[set! (id exp)
|
||||||
|
(set-union
|
||||||
|
(if (set-member? id b) '() (list id))
|
||||||
|
(find-free exp b))]
|
||||||
|
[set& (id)
|
||||||
|
(if (set-member? id b) '() (list id))]
|
||||||
|
[lambda (idsi exp)
|
||||||
|
(find-free exp (set-union (flatten-idslist idsi) b))]
|
||||||
|
[lambda* clauses
|
||||||
|
(find-free* (map cadr clauses) b)]
|
||||||
|
[letcc (kid exp)
|
||||||
|
(find-free exp (set-union (list kid) b))]
|
||||||
|
[withcc (kexp exp)
|
||||||
|
(set-union (find-free kexp b) (find-free exp b))]
|
||||||
|
[if (test then else)
|
||||||
|
(set-union
|
||||||
|
(find-free test b)
|
||||||
|
(set-union (find-free then b) (find-free else b)))]
|
||||||
|
[begin exps
|
||||||
|
(find-free* exps b)]
|
||||||
|
[integrable (ig . args)
|
||||||
|
(find-free* args b)]
|
||||||
|
[call (exp . args)
|
||||||
|
(set-union (find-free exp b) (find-free* args b))]
|
||||||
|
[define tail
|
||||||
|
(c-error "misplaced define form" x)])))
|
||||||
|
|
||||||
|
(define find-sets*
|
||||||
|
(lambda (x* v)
|
||||||
|
(if (null? x*)
|
||||||
|
'()
|
||||||
|
(set-union
|
||||||
|
(find-sets (car x*) v)
|
||||||
|
(find-sets* (cdr x*) v)))))
|
||||||
|
|
||||||
|
(define find-sets
|
||||||
|
(lambda (x v)
|
||||||
|
(record-case x
|
||||||
|
[quote (obj)
|
||||||
|
'()]
|
||||||
|
[ref (id)
|
||||||
|
'()]
|
||||||
|
[set! (id x)
|
||||||
|
(set-union
|
||||||
|
(if (set-member? id v) (list id) '())
|
||||||
|
(find-sets x v))]
|
||||||
|
[set& (id)
|
||||||
|
(if (set-member? id v) (list id) '())]
|
||||||
|
[lambda (idsi exp)
|
||||||
|
(find-sets exp (set-minus v (flatten-idslist idsi)))]
|
||||||
|
[lambda* clauses
|
||||||
|
(find-sets* (map cadr clauses) v)]
|
||||||
|
[letcc (kid exp)
|
||||||
|
(find-sets exp (set-minus v (list kid)))]
|
||||||
|
[withcc (kexp exp)
|
||||||
|
(set-union (find-sets kexp v) (find-sets exp v))]
|
||||||
|
[begin exps
|
||||||
|
(find-sets* exps v)]
|
||||||
|
[if (test then else)
|
||||||
|
(set-union
|
||||||
|
(find-sets test v)
|
||||||
|
(set-union (find-sets then v) (find-sets else v)))]
|
||||||
|
[integrable (ig . args)
|
||||||
|
(find-sets* args v)]
|
||||||
|
[call (exp . args)
|
||||||
|
(set-union (find-sets exp v) (find-sets* args v))]
|
||||||
|
[define tail
|
||||||
|
(c-error "misplaced define form" x)])))
|
||||||
|
|
||||||
|
(define codegen
|
||||||
|
; x: Scheme Core expression to compile
|
||||||
|
; l: local var list (with #f placeholders for nonvar slots)
|
||||||
|
; f: free var list
|
||||||
|
; s: set! var set
|
||||||
|
; g: global var set
|
||||||
|
; k: #f: x goes to ac, N: x is to be returned after (sdrop n)
|
||||||
|
; port: output code goes here
|
||||||
|
(lambda (x l f s g k port)
|
||||||
|
(record-case x
|
||||||
|
[quote (obj)
|
||||||
|
(case obj
|
||||||
|
[(#t) (write-char #\t port)]
|
||||||
|
[(#f) (write-char #\f port)]
|
||||||
|
[(()) (write-char #\n port)]
|
||||||
|
[else (write-char #\' port) (write-serialized-arg obj port)])
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[ref (id)
|
||||||
|
(cond [(posq id l) => ; local
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\. port)
|
||||||
|
(write-serialized-arg n port)
|
||||||
|
(if (set-member? id s) (write-char #\^ port)))]
|
||||||
|
[(posq id f) => ; free
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\: port)
|
||||||
|
(write-serialized-arg n port)
|
||||||
|
(if (set-member? id s) (write-char #\^ port)))]
|
||||||
|
[else ; global
|
||||||
|
(write-char #\@ port)
|
||||||
|
(write-serialized-arg id port)])
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[set! (id x)
|
||||||
|
(codegen x l f s g #f port)
|
||||||
|
(cond [(posq id l) => ; local
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\. port) (write-char #\! port)
|
||||||
|
(write-serialized-arg n port))]
|
||||||
|
[(posq id f) => ; free
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\: port) (write-char #\! port)
|
||||||
|
(write-serialized-arg n port))]
|
||||||
|
[else ; global
|
||||||
|
(write-char #\@ port) (write-char #\! port)
|
||||||
|
(write-serialized-arg id port)])
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[set& (id)
|
||||||
|
(cond [(posq id l) => ; local
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\. port)
|
||||||
|
(write-serialized-arg n port))]
|
||||||
|
[(posq id f) => ; free
|
||||||
|
(lambda (n)
|
||||||
|
(write-char #\: port)
|
||||||
|
(write-serialized-arg n port))]
|
||||||
|
[else ; global
|
||||||
|
(write-char #\` port)
|
||||||
|
(write-serialized-arg id port)])
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[begin exps
|
||||||
|
(let loop ([xl exps])
|
||||||
|
(when (pair? xl)
|
||||||
|
(let ([k (if (pair? (cdr xl)) #f k)])
|
||||||
|
(codegen (car xl) l f s g k port)
|
||||||
|
(loop (cdr xl)))))
|
||||||
|
(when (and k (null? exps)) (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[if (test then else)
|
||||||
|
(codegen test l f s g #f port)
|
||||||
|
(write-char #\? port)
|
||||||
|
(write-char #\{ port)
|
||||||
|
(codegen then l f s g k port)
|
||||||
|
(write-char #\} port)
|
||||||
|
(cond [k ; tail call: 'then' arm exits, so br around is not needed
|
||||||
|
(codegen else l f s g k port)]
|
||||||
|
[(equal? else '(begin)) ; non-tail with void 'else' arm
|
||||||
|
] ; no code needed -- ac retains #f from failed test
|
||||||
|
[else ; non-tail with 'else' expression; needs br
|
||||||
|
(write-char #\{ port)
|
||||||
|
(codegen else l f s g k port)
|
||||||
|
(write-char #\} port)])]
|
||||||
|
[lambda (idsi exp)
|
||||||
|
(let* ([ids (flatten-idslist idsi)]
|
||||||
|
[free (set-minus (find-free exp ids) g)]
|
||||||
|
[sets (find-sets exp ids)])
|
||||||
|
(do ([free (reverse free) (cdr free)] [l l (cons #f l)]) [(null? free)]
|
||||||
|
; note: called with empty set! var list
|
||||||
|
; to make sure no dereferences are generated
|
||||||
|
(codegen (list 'ref (car free)) l f '() g #f port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(write-char #\& port)
|
||||||
|
(write-serialized-arg (length free) port)
|
||||||
|
(write-char #\{ port)
|
||||||
|
(cond [(list? idsi)
|
||||||
|
(write-char #\% port)
|
||||||
|
(write-serialized-arg (length idsi) port)]
|
||||||
|
[else
|
||||||
|
(write-char #\% port) (write-char #\! port)
|
||||||
|
(write-serialized-arg (idslist-req-count idsi) port)])
|
||||||
|
(do ([ids ids (cdr ids)] [n 0 (fx+ n 1)]) [(null? ids)]
|
||||||
|
(when (set-member? (car ids) sets)
|
||||||
|
(write-char #\# port)
|
||||||
|
(write-serialized-arg n port)))
|
||||||
|
(codegen exp ids free
|
||||||
|
(set-union sets (set-intersect s free))
|
||||||
|
g (length ids) port)
|
||||||
|
(write-char #\} port))
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[lambda* clauses
|
||||||
|
(do ([clauses (reverse clauses) (cdr clauses)] [l l (cons #f l)])
|
||||||
|
[(null? clauses)]
|
||||||
|
(codegen (cadr (car clauses)) l f s g #f port)
|
||||||
|
(write-char #\% port) (write-char #\x port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(write-char #\& port)
|
||||||
|
(write-serialized-arg (length clauses) port)
|
||||||
|
(write-char #\{ port)
|
||||||
|
(do ([clauses clauses (cdr clauses)] [i 0 (fx+ i 1)])
|
||||||
|
[(null? clauses)]
|
||||||
|
(let* ([arity (caar clauses)] [cnt (car arity)] [rest? (cadr arity)])
|
||||||
|
(write-char #\| port)
|
||||||
|
(if rest? (write-char #\! port))
|
||||||
|
(write-serialized-arg cnt port)
|
||||||
|
(write-serialized-arg i port)))
|
||||||
|
(write-char #\% port) (write-char #\% port)
|
||||||
|
(write-char #\} port)
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[letcc (kid exp)
|
||||||
|
(let* ([ids (list kid)] [sets (find-sets exp ids)]
|
||||||
|
[news (set-union (set-minus s ids) sets)])
|
||||||
|
(cond [k ; tail position with k locals on stack to be disposed of
|
||||||
|
(write-char #\k port) (write-serialized-arg k port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(when (set-member? kid sets)
|
||||||
|
(write-char #\# port) (write-char #\0 port))
|
||||||
|
; stack map here: kid on top
|
||||||
|
(codegen exp (cons kid l) f news g (fx+ k 1) port)]
|
||||||
|
[else ; non-tail position
|
||||||
|
(write-char #\$ port) (write-char #\{ port)
|
||||||
|
(write-char #\k port) (write-char #\0 port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(when (set-member? kid sets)
|
||||||
|
(write-char #\# port) (write-char #\0 port))
|
||||||
|
; stack map here: kid on top, two-slot frame under it
|
||||||
|
(codegen exp (cons kid (cons #f (cons #f l))) f news g #f port)
|
||||||
|
(write-char #\_ port) (write-serialized-arg 3 port)
|
||||||
|
(write-char #\} port)]))]
|
||||||
|
[withcc (kexp exp)
|
||||||
|
(cond [(memq (car exp) '(quote ref lambda)) ; exp is a constant, return it
|
||||||
|
(codegen exp l f s g #f port)
|
||||||
|
(write-char #\, port) ; stack map after: k on top
|
||||||
|
(codegen kexp (cons #f l) f s g #f port)
|
||||||
|
(write-char #\w port) (write-char #\! port)]
|
||||||
|
[else ; exp is not a constant, thunk it and call it from k
|
||||||
|
(codegen (list 'lambda '() exp) l f s g #f port)
|
||||||
|
(write-char #\, port) ; stack map after: k on top
|
||||||
|
(codegen kexp (cons #f l) f s g #f port)
|
||||||
|
(write-char #\w port)])]
|
||||||
|
[integrable (ig . args)
|
||||||
|
(let ([igty (integrable-type ig)] [igc0 (integrable-code ig 0)])
|
||||||
|
(case igty
|
||||||
|
[(#\0 #\1 #\2 #\3) ; 1st arg in a, others on stack
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(unless (null? (cdr args)) (write-char #\, port)))
|
||||||
|
(write-string igc0 port)]
|
||||||
|
[(#\p) ; (length args) >= 0
|
||||||
|
(if (null? args)
|
||||||
|
(let ([igc1 (integrable-code ig 1)])
|
||||||
|
(write-string igc1 port))
|
||||||
|
(let ([opc (fx- (length args) 1)])
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(unless (null? (cdr args)) (write-char #\, port)))
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx>=? i opc)]
|
||||||
|
(write-string igc0 port))))]
|
||||||
|
[(#\m) ; (length args) >= 1
|
||||||
|
(if (null? (cdr args))
|
||||||
|
(let ([igc1 (integrable-code ig 1)])
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-string igc1 port))
|
||||||
|
(let ([opc (fx- (length args) 1)])
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(unless (null? (cdr args)) (write-char #\, port)))
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx>=? i opc)]
|
||||||
|
(write-string igc0 port))))]
|
||||||
|
[(#\c) ; (length args) >= 2
|
||||||
|
(let ([opc (fx- (length args) 1)] [args (reverse args)])
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(do ([args (cdr args) (cdr args)] [l (cons #f l) (cons #f (cons #f l))])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(unless (null? (cdr args)) (write-char #\, port) (write-char #\, port)))
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx>=? i opc)]
|
||||||
|
(unless (fxzero? i) (write-char #\; port))
|
||||||
|
(write-string igc0 port)))]
|
||||||
|
[(#\x) ; (length args) >= 1
|
||||||
|
(let ([opc (fx- (length args) 1)])
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(unless (null? (cdr args)) (write-char #\, port)))
|
||||||
|
(do ([i 0 (fx+ i 1)]) [(fx>=? i opc)]
|
||||||
|
(write-string igc0 port)))]
|
||||||
|
[(#\u) ; 0 <= (length args) <= 1
|
||||||
|
(if (null? args)
|
||||||
|
(write-string (integrable-code ig 1) port)
|
||||||
|
(codegen (car args) l f s g #f port))
|
||||||
|
(write-string igc0 port)]
|
||||||
|
[(#\b) ; 1 <= (length args) <= 2
|
||||||
|
(if (null? (cdr args))
|
||||||
|
(write-string (integrable-code ig 1) port)
|
||||||
|
(codegen (cadr args) l f s g #f port))
|
||||||
|
(write-char #\, port)
|
||||||
|
(codegen (car args) (cons #f l) f s g #f port)
|
||||||
|
(write-string igc0 port)]
|
||||||
|
[(#\t) ; 2 <= (length args) <= 3
|
||||||
|
(if (null? (cddr args))
|
||||||
|
(write-string (integrable-code ig 1) port)
|
||||||
|
(codegen (caddr args) l f s g #f port))
|
||||||
|
(write-char #\, port)
|
||||||
|
(codegen (cadr args) (cons #f l) f s g #f port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(codegen (car args) (cons #f (cons #f l)) f s g #f port)
|
||||||
|
(write-string igc0 port)]
|
||||||
|
[(#\#) ; (length args) >= 0
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(write-string igc0 port)
|
||||||
|
(write-serialized-arg (length args) port)]
|
||||||
|
[else (c-error "unsupported integrable type" igty)]))
|
||||||
|
(when k (write-char #\] port) (write-serialized-arg k port))]
|
||||||
|
[call (exp . args)
|
||||||
|
(cond [(and (eq? (car exp) 'lambda) (list? (cadr exp))
|
||||||
|
(fx=? (length args) (length (cadr exp))))
|
||||||
|
; let-like call; compile as special lambda + call combo
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(let* ([ids (cadr exp)] [exp (caddr exp)]
|
||||||
|
[sets (find-sets exp ids)]
|
||||||
|
[news (set-union (set-minus s ids) sets)]
|
||||||
|
[newl (append ids l)]) ; with real names
|
||||||
|
(do ([ids ids (cdr ids)] [n 0 (fx+ n 1)]) [(null? ids)]
|
||||||
|
(when (set-member? (car ids) sets)
|
||||||
|
(write-char #\# port)
|
||||||
|
(write-serialized-arg n port)))
|
||||||
|
(if k
|
||||||
|
(codegen exp newl f news g (fx+ k (length args)) port)
|
||||||
|
(begin
|
||||||
|
(codegen exp newl f news g #f port)
|
||||||
|
(write-char #\_ port)
|
||||||
|
(write-serialized-arg (length args) port))))]
|
||||||
|
[k ; tail call with k elements under arguments
|
||||||
|
(do ([args (reverse args) (cdr args)] [l l (cons #f l)])
|
||||||
|
[(null? args) (codegen exp l f s g #f port)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(write-char #\[ port)
|
||||||
|
(write-serialized-arg k port)
|
||||||
|
(write-serialized-arg (length args) port)]
|
||||||
|
[else ; non-tail call; 'save' puts 2 extra elements on the stack!
|
||||||
|
(write-char #\$ port) (write-char #\{ port)
|
||||||
|
(do ([args (reverse args) (cdr args)] [l (cons #f (cons #f l)) (cons #f l)])
|
||||||
|
[(null? args) (codegen exp l f s g #f port)]
|
||||||
|
(codegen (car args) l f s g #f port)
|
||||||
|
(write-char #\, port))
|
||||||
|
(write-char #\[ port)
|
||||||
|
(write-serialized-arg 0 port)
|
||||||
|
(write-serialized-arg (length args) port)
|
||||||
|
(write-char #\} port)])]
|
||||||
|
[define tail
|
||||||
|
(c-error "misplaced define form" x)])))
|
||||||
|
|
||||||
|
(define (compile-to-string x)
|
||||||
|
(let ([p (open-output-string)])
|
||||||
|
(codegen x '() '() '() (find-free x '()) #f p)
|
||||||
|
(get-output-string p)))
|
||||||
|
|
||||||
|
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
; Code deserialization and execution
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
;(define (execute-thunk-closure t) (t))
|
||||||
|
|
||||||
|
; (define (make-closure code) ...) -- need builtin?
|
||||||
|
|
||||||
|
;(define execute
|
||||||
|
; (lambda (code)
|
||||||
|
; (execute-thunk-closure (make-closure code))))
|
||||||
|
|
||||||
|
;(define decode-sexp deserialize-sexp)
|
||||||
|
|
||||||
|
;(define decode deserialize-code)
|
||||||
|
|
||||||
|
;(define (evaluate x)
|
||||||
|
; (execute (decode (compile-to-string (transform #f x)))))
|
||||||
|
|
||||||
|
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
; Environments
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
|
||||||
; new lookup procedure for alist-like macro environments
|
; new lookup procedure for alist-like macro environments
|
||||||
|
|
||||||
(define (env-lookup id env full?) ;=> location (| #f)
|
(define (env-lookup id env full?) ;=> location (| #f)
|
||||||
|
|
@ -677,6 +1160,12 @@
|
||||||
(define (root-environment id)
|
(define (root-environment id)
|
||||||
(env-lookup id *root-environment* #t))
|
(env-lookup id *root-environment* #t))
|
||||||
|
|
||||||
|
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
; Evaluation
|
||||||
|
;---------------------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
||||||
(define (transform! x)
|
(define (transform! x)
|
||||||
(let ([t (xform #t x root-environment)])
|
(let ([t (xform #t x root-environment)])
|
||||||
(when (and (syntax-match? '(define-syntax * *) t) (id? (cadr t))) ; (procedure? (caddr t))
|
(when (and (syntax-match? '(define-syntax * *) t) (id? (cadr t))) ; (procedure? (caddr t))
|
||||||
|
|
@ -696,3 +1185,18 @@
|
||||||
(newline))
|
(newline))
|
||||||
(loop (read p))))
|
(loop (read p))))
|
||||||
(close-input-port p))
|
(close-input-port p))
|
||||||
|
|
||||||
|
(define (visit/c f)
|
||||||
|
(define p (open-input-file f))
|
||||||
|
(let loop ([x (read p)])
|
||||||
|
(unless (eof-object? x)
|
||||||
|
(let ([t (transform! x)])
|
||||||
|
(write t) (newline)
|
||||||
|
(let exec ([x t])
|
||||||
|
(record-case x
|
||||||
|
[begin x* (for-each exec x*)]
|
||||||
|
[define (i v) (exec (list 'set! i v))]
|
||||||
|
[define-syntax (i m)]
|
||||||
|
[else (write (compile-to-string x)) (newline)])))
|
||||||
|
(loop (read p))))
|
||||||
|
(close-input-port p))
|
||||||
|
|
|
||||||
226
t.c
226
t.c
|
|
@ -320,6 +320,223 @@ char *t_code[] = {
|
||||||
"[02}}.0a,.0a,.1da,${:2,:3,.5,:4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51"
|
"[02}}.0a,.0a,.1da,${:2,:3,.5,:4^[03},.0?{.0,.0,.3,.5,:1^[63}.4d,:0^[51"
|
||||||
"}.!0.0^_1[21}](i12)",
|
"}.!0.0^_1[21}](i12)",
|
||||||
|
|
||||||
|
"P", "write-serialized-char",
|
||||||
|
"%2'(c%25),.1C=,.0?{.0}{'(c%22),.2C=,.0?{.0}{'(c%5c),.3C=,.0?{.0}{'(c )"
|
||||||
|
",.4C<,.0?{.0}{'(c~),.5C>}_1}_1}_1}_1?{.1,'(c%25)W0'(i16),.1X8X6,'1,.1S"
|
||||||
|
"3I=?{.2,'(c0)W0}.2,.1,@(y12:write-string)[32}.1,.1W0]2",
|
||||||
|
|
||||||
|
"P", "write-serialized-byte",
|
||||||
|
"%2'(i16),.1X6,'1,.1S3I=?{.2,'(c0)W0}.2,.1,@(y12:write-string)[32",
|
||||||
|
|
||||||
|
"P", "write-serialized-size",
|
||||||
|
"%2${.3,'(i10),.4X6,@(y12:write-string)[02}.1,'(c:)W0]2",
|
||||||
|
|
||||||
|
"P", "write-serialized-element",
|
||||||
|
"%2${.3,.3,@(y21:write-serialized-sexp)[02}.1,'(c;)W0]2",
|
||||||
|
|
||||||
|
"P", "write-serialized-sexp",
|
||||||
|
"%2f,.1q?{.1,'(cf)W0]2}t,.1q?{.1,'(ct)W0]2}n,.1q?{.1,'(cn)W0]2}.0C0?{.1"
|
||||||
|
",'(cc)W0.1,.1,@(y21:write-serialized-char)[22}.0N0?{.1,.1%nI0?{'(ci)}{"
|
||||||
|
"'(cj)}W0.1,'(i10),.2E8,@(y12:write-string)[22}.0L0?{.1,'(cl)W0${.3,.3g"
|
||||||
|
",@(y21:write-serialized-size)[02}.0,,#0.0,.4,&2{%1.0u?{]1}${:0,.3a,@(y"
|
||||||
|
"24:write-serialized-element)[02}.0d,:1^[11}.!0.0^_1[21}.0p?{.1,'(cp)W0"
|
||||||
|
"${.3,.3a,@(y24:write-serialized-element)[02}.1,.1d,@(y24:write-seriali"
|
||||||
|
"zed-element)[22}.0V0?{.1,'(cv)W0${.3,.3V3,@(y21:write-serialized-size)"
|
||||||
|
"[02}'0,,#0.0,.3,.5,&3{%1:1V3,.1I=?{]1}${:0,.3,:1V4,@(y24:write-seriali"
|
||||||
|
"zed-element)[02}'1,.1I+,:2^[11}.!0.0^_1[21}.0S0?{.1,'(cs)W0${.3,.3S3,@"
|
||||||
|
"(y21:write-serialized-size)[02}'0,,#0.0,.3,.5,&3{%1:1S3,.1I=?{]1}${:0,"
|
||||||
|
".3,:1S4,@(y21:write-serialized-char)[02}'1,.1I+,:2^[11}.!0.0^_1[21}.0B"
|
||||||
|
"0?{.1,'(cb)W0${.3,.3B3,@(y21:write-serialized-size)[02}'0,,#0.0,.3,.5,"
|
||||||
|
"&3{%1:1B3,.1I=?{]1}${:0,.3,:1B4,@(y21:write-serialized-byte)[02}'1,.1I"
|
||||||
|
"+,:2^[11}.!0.0^_1[21}.0Y0?{.1,'(cy)W0.0X4,${.4,.3S3,@(y21:write-serial"
|
||||||
|
"ized-size)[02}'0,,#0.0,.3,.6,&3{%1:1S3,.1I=?{]1}${:0,.3,:1S4,@(y21:wri"
|
||||||
|
"te-serialized-char)[02}'1,.1I+,:2^[11}.!0.0^_1[31}.0Y2?{.1,'(cz)W0.1,."
|
||||||
|
"1z,@(y24:write-serialized-element)[22}.0,'(s21:cannot encode literal),"
|
||||||
|
"@(y7:c-error)[22",
|
||||||
|
|
||||||
|
"P", "write-serialized-arg",
|
||||||
|
"%2.0N0?{.0%nI0?{.0,'0I>!?{'9,.1I>!}{f}}{f}}{f}?{.1,.1,'(s10:0123456789"
|
||||||
|
")S4W0]2}.1,'(c()W0${.3,.3,@(y21:write-serialized-sexp)[02}.1,'(c))W0]2",
|
||||||
|
|
||||||
|
"P", "c-error",
|
||||||
|
"%!1.0,.2,'(s10:compiler: )S6,@(y6:error*)[22",
|
||||||
|
|
||||||
|
"P", "find-free*",
|
||||||
|
"%2.0u?{n]2}${.3,.3d,@(y10:find-free*)[02},${.4,.4a,@(y9:find-free)[02}"
|
||||||
|
",@(y9:set-union)[22",
|
||||||
|
|
||||||
|
"P", "find-free",
|
||||||
|
"%2'(y5:quote),.1aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(y3:ref),.1"
|
||||||
|
"aq?{.0d,.2,&1{%1${:0,.3,@(y11:set-member?)[02}?{n]1}.0,l1]1},@(y13:app"
|
||||||
|
"ly-to-list)[22}'(y4:set!),.1aq?{.0d,.2,&1{%2${:0,.4,@(y9:find-free)[02"
|
||||||
|
"},${:0,.4,@(y11:set-member?)[02}?{n}{.1,l1},@(y9:set-union)[22},@(y13:"
|
||||||
|
"apply-to-list)[22}'(y4:set&),.1aq?{.0d,.2,&1{%1${:0,.3,@(y11:set-membe"
|
||||||
|
"r?)[02}?{n]1}.0,l1]1},@(y13:apply-to-list)[22}'(y6:lambda),.1aq?{.0d,."
|
||||||
|
"2,&1{%2${:0,${.5,@(y15:flatten-idslist)[01},@(y9:set-union)[02},.2,@(y"
|
||||||
|
"9:find-free)[22},@(y13:apply-to-list)[22}'(y7:lambda*),.1aq?{.0d,.2,&1"
|
||||||
|
"{%!0:0,${.3,@(y4:cadr),@(y5:%25map1)[02},@(y10:find-free*)[12},@(y13:a"
|
||||||
|
"pply-to-list)[22}'(y5:letcc),.1aq?{.0d,.2,&1{%2${:0,.3,l1,@(y9:set-uni"
|
||||||
|
"on)[02},.2,@(y9:find-free)[22},@(y13:apply-to-list)[22}'(y6:withcc),.1"
|
||||||
|
"aq?{.0d,.2,&1{%2${:0,.4,@(y9:find-free)[02},${:0,.4,@(y9:find-free)[02"
|
||||||
|
"},@(y9:set-union)[22},@(y13:apply-to-list)[22}'(y2:if),.1aq?{.0d,.2,&1"
|
||||||
|
"{%3${${:0,.7,@(y9:find-free)[02},${:0,.7,@(y9:find-free)[02},@(y9:set-"
|
||||||
|
"union)[02},${:0,.4,@(y9:find-free)[02},@(y9:set-union)[32},@(y13:apply"
|
||||||
|
"-to-list)[22}'(y5:begin),.1aq?{.0d,.2,&1{%!0:0,.1,@(y10:find-free*)[12"
|
||||||
|
"},@(y13:apply-to-list)[22}'(y10:integrable),.1aq?{.0d,.2,&1{%!1:0,.1,@"
|
||||||
|
"(y10:find-free*)[22},@(y13:apply-to-list)[22}'(y4:call),.1aq?{.0d,.2,&"
|
||||||
|
"1{%!1${:0,.3,@(y10:find-free*)[02},${:0,.5,@(y9:find-free)[02},@(y9:se"
|
||||||
|
"t-union)[22},@(y13:apply-to-list)[22}'(y6:define),.1aq?{.0d,.1,&1{%!0:"
|
||||||
|
"0,'(s21:misplaced define form),@(y7:c-error)[12},@(y13:apply-to-list)["
|
||||||
|
"22}'(y16:record-case-miss)]2",
|
||||||
|
|
||||||
|
"P", "find-sets*",
|
||||||
|
"%2.0u?{n]2}${.3,.3d,@(y10:find-sets*)[02},${.4,.4a,@(y9:find-sets)[02}"
|
||||||
|
",@(y9:set-union)[22",
|
||||||
|
|
||||||
|
"P", "find-sets",
|
||||||
|
"%2'(y5:quote),.1aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(y3:ref),.1"
|
||||||
|
"aq?{.0d,&0{%1n]1},@(y13:apply-to-list)[22}'(y4:set!),.1aq?{.0d,.2,&1{%"
|
||||||
|
"2${:0,.4,@(y9:find-sets)[02},${:0,.4,@(y11:set-member?)[02}?{.1,l1}{n}"
|
||||||
|
",@(y9:set-union)[22},@(y13:apply-to-list)[22}'(y4:set&),.1aq?{.0d,.2,&"
|
||||||
|
"1{%1${:0,.3,@(y11:set-member?)[02}?{.0,l1]1}n]1},@(y13:apply-to-list)["
|
||||||
|
"22}'(y6:lambda),.1aq?{.0d,.2,&1{%2${${.4,@(y15:flatten-idslist)[01},:0"
|
||||||
|
",@(y9:set-minus)[02},.2,@(y9:find-sets)[22},@(y13:apply-to-list)[22}'("
|
||||||
|
"y7:lambda*),.1aq?{.0d,.2,&1{%!0:0,${.3,@(y4:cadr),@(y5:%25map1)[02},@("
|
||||||
|
"y10:find-sets*)[12},@(y13:apply-to-list)[22}'(y5:letcc),.1aq?{.0d,.2,&"
|
||||||
|
"1{%2${.2,l1,:0,@(y9:set-minus)[02},.2,@(y9:find-sets)[22},@(y13:apply-"
|
||||||
|
"to-list)[22}'(y6:withcc),.1aq?{.0d,.2,&1{%2${:0,.4,@(y9:find-sets)[02}"
|
||||||
|
",${:0,.4,@(y9:find-sets)[02},@(y9:set-union)[22},@(y13:apply-to-list)["
|
||||||
|
"22}'(y5:begin),.1aq?{.0d,.2,&1{%!0:0,.1,@(y10:find-sets*)[12},@(y13:ap"
|
||||||
|
"ply-to-list)[22}'(y2:if),.1aq?{.0d,.2,&1{%3${${:0,.7,@(y9:find-sets)[0"
|
||||||
|
"2},${:0,.7,@(y9:find-sets)[02},@(y9:set-union)[02},${:0,.4,@(y9:find-s"
|
||||||
|
"ets)[02},@(y9:set-union)[32},@(y13:apply-to-list)[22}'(y10:integrable)"
|
||||||
|
",.1aq?{.0d,.2,&1{%!1:0,.1,@(y10:find-sets*)[22},@(y13:apply-to-list)[2"
|
||||||
|
"2}'(y4:call),.1aq?{.0d,.2,&1{%!1${:0,.3,@(y10:find-sets*)[02},${:0,.5,"
|
||||||
|
"@(y9:find-sets)[02},@(y9:set-union)[22},@(y13:apply-to-list)[22}'(y6:d"
|
||||||
|
"efine),.1aq?{.0d,.1,&1{%!0:0,'(s21:misplaced define form),@(y7:c-error"
|
||||||
|
")[12},@(y13:apply-to-list)[22}'(y16:record-case-miss)]2",
|
||||||
|
|
||||||
|
"P", "codegen",
|
||||||
|
"%7'(y5:quote),.1aq?{.0d,.6,.8,&2{%1.0,t,.1v?{:0,'(ct)W0}{f,.1v?{:0,'(c"
|
||||||
|
"f)W0}{n,.1v?{:0,'(cn)W0}{:0,'(c')W0${:0,.4,@(y20:write-serialized-arg)"
|
||||||
|
"[02}}}}_1:1?{:0,'(c])W0:0,:1,@(y20:write-serialized-arg)[12}]1},@(y13:"
|
||||||
|
"apply-to-list)[72}'(y3:ref),.1aq?{.0d,.6,.8,.5,.7,.6,&5{%1${:0,.3,@(y4"
|
||||||
|
":posq)[02},.0?{.0,:3,'(c.)W0${:3,.3,@(y20:write-serialized-arg)[02}${:"
|
||||||
|
"1,.5,@(y11:set-member?)[02}?{:3,'(c^)W0}_1}{${:2,.4,@(y4:posq)[02},.0?"
|
||||||
|
"{.0,:3,'(c:)W0${:3,.3,@(y20:write-serialized-arg)[02}${:1,.6,@(y11:set"
|
||||||
|
"-member?)[02}?{:3,'(c^)W0}_1}{:3,'(c@)W0${:3,.5,@(y20:write-serialized"
|
||||||
|
"-arg)[02}}_1}_1:4?{:3,'(c])W0:3,:4,@(y20:write-serialized-arg)[12}]1},"
|
||||||
|
"@(y13:apply-to-list)[72}'(y4:set!),.1aq?{.0d,.6,.8,.5,.5,.8,.(i10),&6{"
|
||||||
|
"%2${:4,f,:0,:1,:3,:2,.9,@(y7:codegen)[07}${:2,.3,@(y4:posq)[02},.0?{.0"
|
||||||
|
",:4,'(c.)W0:4,'(c!)W0${:4,.3,@(y20:write-serialized-arg)[02}_1}{${:3,."
|
||||||
|
"4,@(y4:posq)[02},.0?{.0,:4,'(c:)W0:4,'(c!)W0${:4,.3,@(y20:write-serial"
|
||||||
|
"ized-arg)[02}_1}{:4,'(c@)W0:4,'(c!)W0${:4,.5,@(y20:write-serialized-ar"
|
||||||
|
"g)[02}}_1}_1:5?{:4,'(c])W0:4,:5,@(y20:write-serialized-arg)[22}]2},@(y"
|
||||||
|
"13:apply-to-list)[72}'(y4:set&),.1aq?{.0d,.6,.8,.5,.5,&4{%1${:0,.3,@(y"
|
||||||
|
"4:posq)[02},.0?{.0,:2,'(c.)W0${:2,.3,@(y20:write-serialized-arg)[02}_1"
|
||||||
|
"}{${:1,.4,@(y4:posq)[02},.0?{.0,:2,'(c:)W0${:2,.3,@(y20:write-serializ"
|
||||||
|
"ed-arg)[02}_1}{:2,'(c`)W0${:2,.5,@(y20:write-serialized-arg)[02}}_1}_1"
|
||||||
|
":3?{:2,'(c])W0:2,:3,@(y20:write-serialized-arg)[12}]1},@(y13:apply-to-"
|
||||||
|
"list)[72}'(y5:begin),.1aq?{.0d,.6,.8,.4,.6,.8,.(i10),&6{%!0${.2,,#0.0,"
|
||||||
|
":3,:2,:1,:0,:4,:5,&7{%1.0p?{.0dp?{f}{:0},${:1,.3,:2,:3,:4,:5,.9a,@(y7:"
|
||||||
|
"codegen)[07}.1d,:6^[21}]1}.!0.0^_1[01}:5?{.0u}{f}?{:4,'(c])W0:4,:5,@(y"
|
||||||
|
"20:write-serialized-arg)[12}]1},@(y13:apply-to-list)[72}'(y2:if),.1aq?"
|
||||||
|
"{.0d,.6,.6,.6,.6,.6,.(i12),&6{%3${:0,f,:4,:3,:2,:1,.8,@(y7:codegen)[07"
|
||||||
|
"}:0,'(c?)W0:0,'(c{)W0${:0,:5,:4,:3,:2,:1,.9,@(y7:codegen)[07}:0,'(c})W"
|
||||||
|
"0:5?{:0,:5,:4,:3,:2,:1,.8,@(y7:codegen)[37}'(l1:y5:begin;),.3e,.0?{.0]"
|
||||||
|
"4}.3?{:0,'(c{)W0${:0,:5,:4,:3,:2,:1,.(i11),@(y7:codegen)[07}:0,'(c})W0"
|
||||||
|
"]4}f]4},@(y13:apply-to-list)[72}'(y6:lambda),.1aq?{.0d,.6,.8,.7,.7,.7,"
|
||||||
|
".7,&6{%2${.2,@(y15:flatten-idslist)[01},${:3,${.5,.8,@(y9:find-free)[0"
|
||||||
|
"2},@(y9:set-minus)[02},${.3,.6,@(y9:find-sets)[02},${:0,.4A8,,#0.0,:4,"
|
||||||
|
":1,:3,&4{%2.0u?{]2}${:2,f,:0,n,:1,.8,.8a,'(y3:ref),l2,@(y7:codegen)[07"
|
||||||
|
"}:2,'(c,)W0.1,fc,.1d,:3^[22}.!0.0^_1[02}:4,'(c&)W0${:4,.4g,@(y20:write"
|
||||||
|
"-serialized-arg)[02}:4,'(c{)W0.3L0?{:4,'(c%25)W0${:4,.6g,@(y20:write-s"
|
||||||
|
"erialized-arg)[02}}{:4,'(c%25)W0:4,'(c!)W0${:4,${.8,@(y17:idslist-req-"
|
||||||
|
"count)[01},@(y20:write-serialized-arg)[02}}${'0,.5,,#0.0,.6,:4,&3{%2.0"
|
||||||
|
"u?{]2}${:1,.3a,@(y11:set-member?)[02}?{:0,'(c#)W0${:0,.4,@(y20:write-s"
|
||||||
|
"erialized-arg)[02}}'1,.2I+,.1d,:2^[22}.!0.0^_1[02}${:4,.5g,:3,${${.(i1"
|
||||||
|
"0),:2,@(y13:set-intersect)[02},.8,@(y9:set-union)[02},.7,.9,.(i12),@(y"
|
||||||
|
"7:codegen)[07}:4,'(c})W0_1_1_1:5?{:4,'(c])W0:4,:5,@(y20:write-serializ"
|
||||||
|
"ed-arg)[22}]2},@(y13:apply-to-list)[72}'(y7:lambda*),.1aq?{.0d,.6,.8,."
|
||||||
|
"5,.7,.9,.7,&6{%!0${:0,.3A8,,#0.0,:4,:3,:2,:1,&5{%2.0u?{]2}${:3,f,:0,:1"
|
||||||
|
",:2,.8,.8ada,@(y7:codegen)[07}:3,'(c%25)W0:3,'(cx)W0:3,'(c,)W0.1,fc,.1"
|
||||||
|
"d,:4^[22}.!0.0^_1[02}:4,'(c&)W0${:4,.3g,@(y20:write-serialized-arg)[02"
|
||||||
|
"}:4,'(c{)W0${'0,.3,,#0.0,:4,&2{%2.0u?{]2}.0aa,.0a,.1da,:0,'(c|)W0.0?{:"
|
||||||
|
"0,'(c!)W0}${:0,.4,@(y20:write-serialized-arg)[02}${:0,.7,@(y20:write-s"
|
||||||
|
"erialized-arg)[02}_1_1_1'1,.2I+,.1d,:1^[22}.!0.0^_1[02}:4,'(c%25)W0:4,"
|
||||||
|
"'(c%25)W0:4,'(c})W0:5?{:4,'(c])W0:4,:5,@(y20:write-serialized-arg)[12}"
|
||||||
|
"]1},@(y13:apply-to-list)[72}'(y5:letcc),.1aq?{.0d,.4,.7,.7,.6,.6,.(i12"
|
||||||
|
"),&6{%2.0,l1,${.2,.5,@(y9:find-sets)[02},${.2,${.6,:5,@(y9:set-minus)["
|
||||||
|
"02},@(y9:set-union)[02},:4?{:0,'(ck)W0${:0,:4,@(y20:write-serialized-a"
|
||||||
|
"rg)[02}:0,'(c,)W0${.3,.6,@(y11:set-member?)[02}?{:0,'(c#)W0:0,'(c0)W0}"
|
||||||
|
":0,'1,:4I+,:3,.3,:2,:1,.9c,.(i10),@(y7:codegen)[57}:0,'(c$)W0:0,'(c{)W"
|
||||||
|
"0:0,'(ck)W0:0,'(c0)W0:0,'(c,)W0${.3,.6,@(y11:set-member?)[02}?{:0,'(c#"
|
||||||
|
")W0:0,'(c0)W0}${:0,f,:3,.5,:2,:1,fc,fc,.(i11)c,.(i12),@(y7:codegen)[07"
|
||||||
|
"}:0,'(c_)W0${:0,'3,@(y20:write-serialized-arg)[02}:0,'(c})W0]5},@(y13:"
|
||||||
|
"apply-to-list)[72}'(y6:withcc),.1aq?{.0d,.7,.3,.5,.7,.9,&5{%2'(l3:y5:q"
|
||||||
|
"uote;y3:ref;y6:lambda;),.2aA0?{${:4,f,:0,:1,:2,:3,.9,@(y7:codegen)[07}"
|
||||||
|
":4,'(c,)W0${:4,f,:0,:1,:2,:3,fc,.8,@(y7:codegen)[07}:4,'(cw)W0:4,'(c!)"
|
||||||
|
"W0]2}${:4,f,:0,:1,:2,:3,.9,n,'(y6:lambda),l3,@(y7:codegen)[07}:4,'(c,)"
|
||||||
|
"W0${:4,f,:0,:1,:2,:3,fc,.8,@(y7:codegen)[07}:4,'(cw)W0]2},@(y13:apply-"
|
||||||
|
"to-list)[72}'(y10:integrable),.1aq?{.0d,.6,.8,.5,.7,.9,.7,&6{%!1'0,.2U"
|
||||||
|
"8,.2U6,.0,'(l4:c0;c1;c2;c3;),.1A1?{${:0,.6A8,,#0.0,:4,:3,:2,:1,&5{%2.0"
|
||||||
|
"u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7:codegen)[07}.0du~?{:3,'(c,)W0}.1,fc,"
|
||||||
|
".1d,:4^[22}.!0.0^_1[02}${:4,.5,@(y12:write-string)[02}}{'(cp),.1v?{.3u"
|
||||||
|
"?{'1,.5U8,${:4,.3,@(y12:write-string)[02}_1}{'1,.4gI-,${:0,.7A8,,#0.0,"
|
||||||
|
":4,:3,:2,:1,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7:codegen)[07}.0du~"
|
||||||
|
"?{:3,'(c,)W0}.1,fc,.1d,:4^[22}.!0.0^_1[02}${'0,,#0.0,.8,:4,.7,&4{%1:0,"
|
||||||
|
".1I<!?{]1}${:1,:2,@(y12:write-string)[02}'1,.1I+,:3^[11}.!0.0^_1[01}_1"
|
||||||
|
"}}{'(cm),.1v?{.3du?{'1,.5U8,${:4,f,:1,:2,:3,:0,.(i12)a,@(y7:codegen)[0"
|
||||||
|
"7}${:4,.3,@(y12:write-string)[02}_1}{'1,.4gI-,${:0,.7A8,,#0.0,:4,:3,:2"
|
||||||
|
",:1,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7:codegen)[07}.0du~?{:3,'(c"
|
||||||
|
",)W0}.1,fc,.1d,:4^[22}.!0.0^_1[02}${'0,,#0.0,.8,:4,.7,&4{%1:0,.1I<!?{]"
|
||||||
|
"1}${:1,:2,@(y12:write-string)[02}'1,.1I+,:3^[11}.!0.0^_1[01}_1}}{'(cc)"
|
||||||
|
",.1v?{.3A8,'1,.5gI-,${:4,f,:1,:2,:3,:0,.9a,@(y7:codegen)[07}:4,'(c,)W0"
|
||||||
|
"${:0,fc,.4d,,#0.0,:4,:3,:2,:1,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7"
|
||||||
|
":codegen)[07}.0du~?{:3,'(c,)W0:3,'(c,)W0}.1,fc,fc,.1d,:4^[22}.!0.0^_1["
|
||||||
|
"02}${'0,,#0.0,.9,:4,.7,&4{%1:0,.1I<!?{]1}.0I=0~?{:1,'(c;)W0}${:1,:2,@("
|
||||||
|
"y12:write-string)[02}'1,.1I+,:3^[11}.!0.0^_1[01}_2}{'(cx),.1v?{'1,.4gI"
|
||||||
|
"-,${:0,.7A8,,#0.0,:4,:3,:2,:1,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7"
|
||||||
|
":codegen)[07}.0du~?{:3,'(c,)W0}.1,fc,.1d,:4^[22}.!0.0^_1[02}${'0,,#0.0"
|
||||||
|
",.8,:4,.7,&4{%1:0,.1I<!?{]1}${:1,:2,@(y12:write-string)[02}'1,.1I+,:3^"
|
||||||
|
"[11}.!0.0^_1[01}_1}{'(cu),.1v?{.3u?{${:4,'1,.8U8,@(y12:write-string)[0"
|
||||||
|
"2}}{${:4,f,:1,:2,:3,:0,.(i11)a,@(y7:codegen)[07}}${:4,.5,@(y12:write-s"
|
||||||
|
"tring)[02}}{'(cb),.1v?{.3du?{${:4,'1,.8U8,@(y12:write-string)[02}}{${:"
|
||||||
|
"4,f,:1,:2,:3,:0,.(i11)da,@(y7:codegen)[07}}:4,'(c,)W0${:4,f,:1,:2,:3,:"
|
||||||
|
"0,fc,.(i11)a,@(y7:codegen)[07}${:4,.5,@(y12:write-string)[02}}{'(ct),."
|
||||||
|
"1v?{.3ddu?{${:4,'1,.8U8,@(y12:write-string)[02}}{${:4,f,:1,:2,:3,:0,.("
|
||||||
|
"i11)dda,@(y7:codegen)[07}}:4,'(c,)W0${:4,f,:1,:2,:3,:0,fc,.(i11)da,@(y"
|
||||||
|
"7:codegen)[07}:4,'(c,)W0${:4,f,:1,:2,:3,:0,fc,fc,.(i11)a,@(y7:codegen)"
|
||||||
|
"[07}${:4,.5,@(y12:write-string)[02}}{'(c#),.1v?{${:0,.6A8,,#0.0,:4,:3,"
|
||||||
|
":2,:1,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7:codegen)[07}:3,'(c,)W0."
|
||||||
|
"1,fc,.1d,:4^[22}.!0.0^_1[02}${:4,.5,@(y12:write-string)[02}${:4,.6g,@("
|
||||||
|
"y20:write-serialized-arg)[02}}{${.3,'(s27:unsupported integrable type)"
|
||||||
|
",@(y7:c-error)[02}}}}}}}}}}_1_2:5?{:4,'(c])W0:4,:5,@(y20:write-seriali"
|
||||||
|
"zed-arg)[22}]2},@(y13:apply-to-list)[72}'(y4:call),.1aq?{.0d,.7,.4,.6,"
|
||||||
|
".8,.6,.(i11),&6{%!1'(y6:lambda),.2aq?{.1daL0?{.1dag,.1gI=}{f}}{f}?{${:"
|
||||||
|
"1,.3A8,,#0.0,:5,:4,:3,:2,&5{%2.0u?{]2}${:3,f,:0,:1,:2,.8,.8a,@(y7:code"
|
||||||
|
"gen)[07}:3,'(c,)W0.1,fc,.1d,:4^[22}.!0.0^_1[02}.1da,.2dda,${.3,.3,@(y9"
|
||||||
|
":find-sets)[02},${.2,${.7,:3,@(y9:set-minus)[02},@(y9:set-union)[02},:"
|
||||||
|
"1,.4L6,${'0,.7,,#0.0,.8,:5,&3{%2.0u?{]2}${:1,.3a,@(y11:set-member?)[02"
|
||||||
|
"}?{:0,'(c#)W0${:0,.4,@(y20:write-serialized-arg)[02}}'1,.2I+,.1d,:2^[2"
|
||||||
|
"2}.!0.0^_1[02}:0?{:5,.6g,:0I+,:2,.4,:4,.5,.9,@(y7:codegen)[77}${:5,f,:"
|
||||||
|
"2,.6,:4,.7,.(i11),@(y7:codegen)[07}:5,'(c_)W0:5,.6g,@(y20:write-serial"
|
||||||
|
"ized-arg)[72}:0?{${:1,.3A8,,#0.0,:5,:4,:3,:2,.(i11),&6{%2.0u?{:4,f,:1,"
|
||||||
|
":2,:3,.6,:0,@(y7:codegen)[27}${:4,f,:1,:2,:3,.8,.8a,@(y7:codegen)[07}:"
|
||||||
|
"4,'(c,)W0.1,fc,.1d,:5^[22}.!0.0^_1[02}:5,'(c[)W0${:5,:0,@(y20:write-se"
|
||||||
|
"rialized-arg)[02}:5,.1g,@(y20:write-serialized-arg)[22}:5,'(c$)W0:5,'("
|
||||||
|
"c{)W0${:1,fc,fc,.3A8,,#0.0,:5,:4,:3,:2,.(i11),&6{%2.0u?{:4,f,:1,:2,:3,"
|
||||||
|
".6,:0,@(y7:codegen)[27}${:4,f,:1,:2,:3,.8,.8a,@(y7:codegen)[07}:4,'(c,"
|
||||||
|
")W0.1,fc,.1d,:5^[22}.!0.0^_1[02}:5,'(c[)W0${:5,'0,@(y20:write-serializ"
|
||||||
|
"ed-arg)[02}${:5,.3g,@(y20:write-serialized-arg)[02}:5,'(c})W0]2},@(y13"
|
||||||
|
":apply-to-list)[72}'(y6:define),.1aq?{.0d,.1,&1{%!0:0,'(s21:misplaced "
|
||||||
|
"define form),@(y7:c-error)[12},@(y13:apply-to-list)[72}'(y16:record-ca"
|
||||||
|
"se-miss)]7",
|
||||||
|
|
||||||
|
"P", "compile-to-string",
|
||||||
|
"%1P51,${.2,f,${n,.8,@(y9:find-free)[02},n,n,n,.9,@(y7:codegen)[07}.0P9"
|
||||||
|
"0]2",
|
||||||
|
|
||||||
"P", "env-lookup",
|
"P", "env-lookup",
|
||||||
"%3.0K0?{.0,@(y7:old-den)[31}.1,,#0.4,.3,.2,&3{%1.0p?{:1,.1aaq?{.0ad]1}"
|
"%3.0K0?{.0,@(y7:old-den)[31}.1,,#0.4,.3,.2,&3{%1.0p?{:1,.1aaq?{.0ad]1}"
|
||||||
".0d,:0^[11}.0V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:"
|
".0d,:0^[11}.0V0?{.0V3,.0,:1H2,.0,.3V4,.0,:1A3,.0?{.0d]5}:1U5,.0?{.0}{:"
|
||||||
|
|
@ -352,5 +569,14 @@ char *t_code[] = {
|
||||||
",&2{%1.0R8~?{${.2,@(y10:transform!)[01},Po,.1W5PoW6_1${:1^,@(y4:read)["
|
",&2{%1.0R8~?{${.2,@(y10:transform!)[01},Po,.1W5PoW6_1${:1^,@(y4:read)["
|
||||||
"01},:0^[11}]1}.!0.0^_1[01}.0^P60]2",
|
"01},:0^[11}]1}.!0.0^_1[01}.0^P60]2",
|
||||||
|
|
||||||
|
"P", "visit/c",
|
||||||
|
"%1,#0${.3,@(y15:open-input-file)[01}.!0${${.4^,@(y4:read)[01},,#0.4,.1"
|
||||||
|
",&2{%1.0R8~?{${.2,@(y10:transform!)[01},Po,.1W5PoW6${.2,,#0.0,&1{%1'(y"
|
||||||
|
"5:begin),.1aq?{.0d,:0,&1{%!0.0,:0^,@(y10:%25for-each1)[12},@(y13:apply"
|
||||||
|
"-to-list)[12}'(y6:define),.1aq?{.0d,:0,&1{%2.1,.1,'(y4:set!),l3,:0^[21"
|
||||||
|
"},@(y13:apply-to-list)[12}'(y13:define-syntax),.1aq?{.0d,&0{%2]2},@(y1"
|
||||||
|
"3:apply-to-list)[12}Po,${.3,@(y17:compile-to-string)[01}W5PoW6]1}.!0.0"
|
||||||
|
"^_1[01}_1${:1^,@(y4:read)[01},:0^[11}]1}.!0.0^_1[01}.0^P60]2",
|
||||||
|
|
||||||
0, 0, 0
|
0, 0, 0
|
||||||
};
|
};
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue