adding nestlist, to-proper, string.rep, pad-l, pad-r, trace, untrace,
table.invert, table.foreach reorganizing system.lsp so functions are grouped sensibly scheme implementation of a simple bytecode compiler
This commit is contained in:
JeffBezanson
parent
c076be667b
commit
e3158b8640
|
|
@ -0,0 +1,363 @@
|
|||
; -*- scheme -*-
|
||||
|
||||
(define (make-enum-table keys)
|
||||
(let ((e (table)))
|
||||
(for 0 (1- (length keys))
|
||||
(lambda (i)
|
||||
(put! e (aref keys i) i)))))
|
||||
|
||||
(define Instructions
|
||||
(make-enum-table
|
||||
[:nop :dup :pop :popn :call :jmp :brf :brt :jmp.s :brf.s :brt.s :ret
|
||||
|
||||
:eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
|
||||
:number? :bound? :pair? :builtin? :vector? :fixnum?
|
||||
|
||||
:cons :list :car :cdr :set-car! :set-cdr!
|
||||
:eval :eval* :apply
|
||||
|
||||
:+ :- :* :/ :< :lognot :compare
|
||||
|
||||
:vector :aref :aset :length :for
|
||||
|
||||
:loadt :loadf :loadnil :load0 :load1 :loadv :loadv.s
|
||||
:loadg :loada :loadc
|
||||
:setg :seta :setc :loadg.s :setg.s
|
||||
|
||||
:closure :trycatch]))
|
||||
|
||||
(define 1/Instructions (table.invert Instructions))
|
||||
|
||||
(define (make-code-emitter) (vector () (table) 0))
|
||||
(define (emit e inst . args)
|
||||
(if (memq inst '(:loadv :loadg :setg))
|
||||
(let* ((const-to-idx (aref e 1))
|
||||
(nconst (aref e 2))
|
||||
(v (car args))
|
||||
(vind (if (has? const-to-idx v)
|
||||
(get const-to-idx v)
|
||||
(begin (put! const-to-idx v nconst)
|
||||
(set! nconst (+ nconst 1))
|
||||
(- nconst 1)))))
|
||||
(aset! e 2 nconst)
|
||||
(set! args (list vind))
|
||||
(if (< vind 256)
|
||||
(set! inst (case inst
|
||||
(:loadv :loadv.s)
|
||||
(:loadg :loadg.s)
|
||||
(:setg :setg.s))))))
|
||||
(aset! e 0 (nreconc (cons inst args) (aref e 0)))
|
||||
e)
|
||||
|
||||
(define (make-label e) (gensym))
|
||||
(define (mark-label e l) (emit e :label l))
|
||||
|
||||
; convert symbolic bytecode representation to a byte array.
|
||||
; labels are fixed-up.
|
||||
(define (encode-byte-code e)
|
||||
(let ((v (list->vector (nreverse e))))
|
||||
(let ((n (length v))
|
||||
(i 0)
|
||||
(label-to-loc (table))
|
||||
(fixup-to-label (table))
|
||||
(bcode (buffer))
|
||||
(vi #f))
|
||||
(while (< i n)
|
||||
(begin
|
||||
(set! vi (aref v i))
|
||||
(if (eq? vi :label)
|
||||
(begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
|
||||
(set! i (+ i 2)))
|
||||
(begin
|
||||
(io.write bcode (byte (get Instructions vi)))
|
||||
(set! i (+ i 1))
|
||||
(if (< i n)
|
||||
(let ((nxt (aref v i)))
|
||||
(case vi
|
||||
((:loadv :loadg :setg)
|
||||
(io.write bcode (uint32 nxt))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:loada :seta :call :loadv.s :loadg.s :setg.s :popn)
|
||||
(io.write bcode (uint8 nxt))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:loadc :setc) ; 2 uint8 args
|
||||
(io.write bcode (uint8 nxt))
|
||||
(set! i (+ i 1))
|
||||
(io.write bcode (uint8 (aref v i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:jmp :brf :brt)
|
||||
(let ((dest (get label-to-loc nxt #uint32(-1))))
|
||||
(if (< dest 256)
|
||||
(begin (io.seek bcode (1- (sizeof bcode)))
|
||||
(io.write bcode
|
||||
(byte
|
||||
(get Instructions
|
||||
(case vi
|
||||
(:jmp :jmp.s)
|
||||
(:brt :brt.s)
|
||||
(:brf :brf.s)))))
|
||||
(io.write bcode (uint8 dest)))
|
||||
(begin
|
||||
(put! fixup-to-label (sizeof bcode) nxt)
|
||||
(io.write bcode (uint32 0)))))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
(else #f))))))))
|
||||
(table.foreach
|
||||
(lambda (addr labl)
|
||||
(begin (io.seek bcode addr)
|
||||
(io.write bcode (uint32 (get label-to-loc labl)))))
|
||||
fixup-to-label)
|
||||
(io.tostring! bcode))))
|
||||
|
||||
(define (const-to-idx-vec e)
|
||||
(let ((const-to-idx (aref e 1))
|
||||
(nconst (aref e 2)))
|
||||
(let ((cvec (vector.alloc nconst)))
|
||||
(table.foreach (lambda (val idx) (aset! cvec idx val))
|
||||
const-to-idx)
|
||||
cvec)))
|
||||
|
||||
(define (bytecode g)
|
||||
(cons (encode-byte-code (aref g 0))
|
||||
(const-to-idx-vec g)))
|
||||
|
||||
(define (bytecode:code b) (car b))
|
||||
(define (bytecode:vals b) (cdr b))
|
||||
|
||||
(define (index-of item lst start)
|
||||
(cond ((null? lst) #f)
|
||||
((eq item (car lst)) start)
|
||||
(#t (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (in-env? s env)
|
||||
(and (pair? env)
|
||||
(or (index-of s (car env) 0)
|
||||
(in-env? s (cdr env)))))
|
||||
|
||||
(define (lookup-sym s env lev arg?)
|
||||
(if (null? env)
|
||||
'(global)
|
||||
(let* ((curr (car env))
|
||||
(i (index-of s curr 0)))
|
||||
(if i
|
||||
(if arg?
|
||||
`(arg ,i)
|
||||
`(closed ,lev ,i))
|
||||
(lookup-sym s
|
||||
(cdr env)
|
||||
(if (null? curr) lev (+ lev 1))
|
||||
#f)))))
|
||||
|
||||
(define (compile-sym g s env Is)
|
||||
(let ((loc (lookup-sym s env 0 #t)))
|
||||
(case (car loc)
|
||||
(arg (emit g (aref Is 0) (cadr loc)))
|
||||
(closed (emit g (aref Is 1) (cadr loc) (caddr loc)))
|
||||
(else (emit g (aref Is 2) s)))))
|
||||
|
||||
(define (builtin->instruction b)
|
||||
(let ((sym (intern (string #\: b))))
|
||||
(and (has? Instructions sym) sym)))
|
||||
|
||||
(define (cond->if form)
|
||||
(cond-clauses->if (cdr form)))
|
||||
(define (cond-clauses->if lst)
|
||||
(if (atom? lst)
|
||||
lst
|
||||
(let ((clause (car lst)))
|
||||
`(if ,(car clause)
|
||||
,(cons 'begin (cdr clause))
|
||||
,(cond-clauses->if (cdr lst))))))
|
||||
|
||||
(define (compile-if g x env)
|
||||
(let ((elsel (make-label g))
|
||||
(endl (make-label g)))
|
||||
(compile-in g (cadr x) env)
|
||||
(emit g :brf elsel)
|
||||
(compile-in g (caddr x) env)
|
||||
(emit g :jmp endl)
|
||||
(mark-label g elsel)
|
||||
(compile-in g (if (pair? (cdddr x))
|
||||
(cadddr x)
|
||||
#f)
|
||||
env)
|
||||
(mark-label g endl)))
|
||||
|
||||
(define (compile-begin g forms env)
|
||||
(cond ((atom? forms) (compile-in g #f env))
|
||||
((atom? (cdr forms))
|
||||
(compile-in g (car forms) env))
|
||||
(else
|
||||
(compile-in g (car forms) env)
|
||||
(emit g :pop)
|
||||
(compile-begin g (cdr forms) env))))
|
||||
|
||||
(define (compile-prog1 g x env)
|
||||
(compile-in g (cadr x) env)
|
||||
(if (pair? (cddr x))
|
||||
(begin (compile-begin g (cddr x) env)
|
||||
(emit g :pop))))
|
||||
|
||||
(define (compile-while g cond body env)
|
||||
(let ((top (make-label g))
|
||||
(end (make-label g)))
|
||||
(mark-label g top)
|
||||
(compile-in g cond env)
|
||||
(emit g :brf end)
|
||||
(compile-in g body env)
|
||||
(emit g :pop)
|
||||
(emit g :jmp top)
|
||||
(mark-label g end)))
|
||||
|
||||
(define (compile-and g forms env)
|
||||
(cond ((atom? forms) (compile-in g #t env))
|
||||
((atom? (cdr forms)) (compile-in g (car forms) env))
|
||||
(else
|
||||
(let ((end (make-label g)))
|
||||
(compile-in g (car forms) env)
|
||||
(emit g :dup)
|
||||
(emit g :brf end)
|
||||
(emit g :pop)
|
||||
(compile-and g (cdr forms) env)
|
||||
(mark-label g end)))))
|
||||
|
||||
(define (compile-or g forms env)
|
||||
(cond ((atom? forms) (compile-in g #f env))
|
||||
((atom? (cdr forms)) (compile-in g (car forms) env))
|
||||
(else
|
||||
(let ((end (make-label g)))
|
||||
(compile-in g (car forms) env)
|
||||
(emit g :dup)
|
||||
(emit g :brt end)
|
||||
(emit g :pop)
|
||||
(compile-or g (cdr forms) env)
|
||||
(mark-label g end)))))
|
||||
|
||||
;; TODO support long argument lists
|
||||
(define (compile-args g lst env)
|
||||
(for-each (lambda (a)
|
||||
(compile-in g a env))
|
||||
lst))
|
||||
|
||||
(define (compile-app g x env)
|
||||
(let ((head (car x))
|
||||
(nargs (length (cdr x))))
|
||||
(let ((head
|
||||
(if (and (symbol? head)
|
||||
(not (in-env? head env))
|
||||
(bound? head)
|
||||
(constant? head)
|
||||
(builtin? (eval head)))
|
||||
(eval head)
|
||||
head)))
|
||||
(let ((b (and (builtin? head)
|
||||
(builtin->instruction head))))
|
||||
(if (not b)
|
||||
(compile-in g head env))
|
||||
(compile-args g (cdr x) env)
|
||||
(if b ;; TODO check arg count
|
||||
(emit g b)
|
||||
(emit g :call nargs))))))
|
||||
|
||||
(define (compile-in g x env)
|
||||
(cond ((symbol? x) (compile-sym g x env [:loada :loadc :loadg]))
|
||||
((atom? x)
|
||||
(cond ((eq? x 0) (emit g :load0))
|
||||
((eq? x 1) (emit g :load1))
|
||||
((eq? x #t) (emit g :loadt))
|
||||
((eq? x #f) (emit g :loadf))
|
||||
((eq? x ()) (emit g :loadnil))
|
||||
(else (emit g :loadv x))))
|
||||
(else
|
||||
(case (car x)
|
||||
(quote (emit g :loadv (cadr x)))
|
||||
(cond (compile-in g (cond->if x) env))
|
||||
(if (compile-if g x env))
|
||||
(begin (compile-begin g (cdr x) env))
|
||||
(prog1 (compile-prog1 g x env))
|
||||
(lambda (begin (emit g :loadv (compile-f x env))
|
||||
(emit g :closure)))
|
||||
(and (compile-and g (cdr x) env))
|
||||
(or (compile-or g (cdr x) env))
|
||||
(while (compile-while g (car x) (cadr x) env))
|
||||
(set! (compile-in g (caddr x) env)
|
||||
(compile-sym g (cadr x) env [:seta :setc :setg]))
|
||||
(trycatch (compile-in g `(lambda () ,(cadr x)) env)
|
||||
(compile-in g (caddr x))
|
||||
(emit g :trycatch))
|
||||
(else (compile-app g x env))))))
|
||||
|
||||
(define (compile-f f env)
|
||||
(let ((g (make-code-emitter)))
|
||||
(compile-in g (caddr f) (cons (to-proper (cadr f)) env))
|
||||
(emit g :ret)
|
||||
`(compiled-lambda ,(cadr f) ,(bytecode g))))
|
||||
|
||||
(define (compile x)
|
||||
(compile-in (make-code-emitter) x ()))
|
||||
|
||||
(define (ref-uint32-LE a i)
|
||||
(+ (ash (aref a (+ i 0)) 0)
|
||||
(ash (aref a (+ i 1)) 8)
|
||||
(ash (aref a (+ i 2)) 16)
|
||||
(ash (aref a (+ i 3)) 24)))
|
||||
|
||||
(define (hex5 n)
|
||||
(pad-l (number->string n 16) 5 #\0))
|
||||
|
||||
(define (disassemble- b lev)
|
||||
(if (and (pair? b)
|
||||
(eq? (car b) 'compiled-lambda))
|
||||
(disassemble- (caddr b) lev)
|
||||
(let ((code (bytecode:code b))
|
||||
(vals (bytecode:vals b)))
|
||||
(define (print-val v)
|
||||
(if (and (pair? v) (eq? (car v) 'compiled-lambda))
|
||||
(begin (princ "\n")
|
||||
(disassemble- v (+ lev 1)))
|
||||
(print v)))
|
||||
(let ((i 0)
|
||||
(N (length code)))
|
||||
(while (< i N)
|
||||
(let ((inst (get 1/Instructions (aref code i))))
|
||||
(if (> i 0) (newline))
|
||||
(dotimes (xx lev) (princ "\t"))
|
||||
(princ (hex5 i) ": "
|
||||
(string.tail (string inst) 1) "\t")
|
||||
(set! i (+ i 1))
|
||||
(case inst
|
||||
((:loadv :loadg :setg)
|
||||
(print-val (aref vals (ref-uint32-LE code i)))
|
||||
(set! i (+ i 4)))
|
||||
|
||||
((:loadv.s :loadg.s :setg.s)
|
||||
(print-val (aref vals (aref code i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:loada :seta :call :popn)
|
||||
(princ (number->string (aref code i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:loadc :setc)
|
||||
(princ (number->string (aref code i)) " ")
|
||||
(set! i (+ i 1))
|
||||
(princ (number->string (aref code i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
((:jmp :brf :brt)
|
||||
(princ "@" (hex5 (ref-uint32-LE code i)))
|
||||
(set! i (+ i 4)))
|
||||
|
||||
((:jmp.s :brf.s :brt.s)
|
||||
(princ "@" (hex5 (aref code i)))
|
||||
(set! i (+ i 1)))
|
||||
|
||||
(else #f))))))))
|
||||
|
||||
(define (disassemble b) (disassemble- b 0))
|
||||
|
||||
#t
|
||||
|
|
@ -302,6 +302,8 @@ todo:
|
|||
|
||||
* handle dotted arglists in lambda
|
||||
|
||||
- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done))
|
||||
|
||||
- implement CPS version of apply
|
||||
|
||||
- use fewer gensyms
|
||||
|
|
|
|||
|
|
@ -11,21 +11,6 @@
|
|||
(logand ~L b ~R)
|
||||
(logand ~L ~b R)))))
|
||||
|
||||
(define (nestlist f zero n)
|
||||
(if (<= n 0) ()
|
||||
(cons zero (nestlist f (f zero) (- n 1)))))
|
||||
|
||||
(define (string.rep s k)
|
||||
(cond ((< k 4)
|
||||
(cond ((<= k 0) "")
|
||||
((= k 1) (string s))
|
||||
((= k 2) (string s s))
|
||||
(else (string s s s))))
|
||||
((odd? k) (string s (string.rep s (- k 1))))
|
||||
(else (string.rep (string s s) (/ k 2)))))
|
||||
|
||||
(define (pad0 s n) (string (string.rep "0" (- n (length s))) s))
|
||||
|
||||
(define (bin-draw s)
|
||||
(string.map (lambda (c) (case c
|
||||
(#\1 #\#)
|
||||
|
|
@ -35,6 +20,6 @@
|
|||
|
||||
(for-each (lambda (n)
|
||||
(begin
|
||||
(princ (bin-draw (pad0 (number->string n 2) 63)))
|
||||
(princ (bin-draw (pad-l (number->string n 2) 63 #\0)))
|
||||
(newline)))
|
||||
(nestlist rule30-step (uint64 0x0000000080000000) 32))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
; convert a sequence of body statements to a single expression.
|
||||
; this allows define, defun, defmacro, let, etc. to contain multiple
|
||||
; body expressions as in Common Lisp.
|
||||
; body expressions.
|
||||
(set! f-body (lambda (e)
|
||||
(cond ((atom? e) #f)
|
||||
((eq (cdr e) ()) (car e))
|
||||
|
|
@ -21,12 +21,7 @@
|
|||
(list 'set! form (car body))
|
||||
(list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
|
||||
|
||||
(define *output-stream* *stdout*)
|
||||
(define *input-stream* *stdin*)
|
||||
(define (print . args)
|
||||
(apply io.print (cons *output-stream* args)))
|
||||
(define (princ . args)
|
||||
(apply io.princ (cons *output-stream* args)))
|
||||
(define-macro (body . forms) (f-body forms))
|
||||
|
||||
(define (set s v) (eval (list 'set! s (list 'quote v))))
|
||||
|
||||
|
|
@ -55,6 +50,8 @@
|
|||
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
|
||||
#f))
|
||||
|
||||
; standard procedures ---------------------------------------------------------
|
||||
|
||||
(define (append . lsts)
|
||||
(cond ((null? lsts) ())
|
||||
((null? (cdr lsts)) (car lsts))
|
||||
|
|
@ -82,95 +79,6 @@
|
|||
((eqv? (caar lst) item) (car lst))
|
||||
(#t (assv item (cdr lst)))))
|
||||
|
||||
(define (macrocall? e) (and (symbol? (car e))
|
||||
(symbol-syntax (car e))))
|
||||
|
||||
(define (function? x)
|
||||
(or (builtin? x)
|
||||
(and (pair? x) (eq (car x) 'lambda))))
|
||||
(define procedure? function?)
|
||||
|
||||
(define (macroexpand-1 e)
|
||||
(if (atom? e) e
|
||||
(let ((f (macrocall? e)))
|
||||
(if f (apply f (cdr e))
|
||||
e))))
|
||||
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
|
||||
(define (macroexpand e) (macroexpand-in e ()))
|
||||
|
||||
(define (macroexpand-in e env)
|
||||
(if (atom? e) e
|
||||
(let ((f (assq (car e) env)))
|
||||
(if f
|
||||
(macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
|
||||
(let ((f (macrocall? e)))
|
||||
(if f
|
||||
(macroexpand-in (apply f (cdr e)) env)
|
||||
(cond ((eq (car e) 'quote) e)
|
||||
((eq (car e) 'lambda)
|
||||
(nlist* 'lambda (cadr e)
|
||||
(macroexpand-in (caddr e) env)
|
||||
(cdddr e)))
|
||||
((eq (car e) 'let-syntax)
|
||||
(let ((binds (cadr e))
|
||||
(body (f-body (cddr e))))
|
||||
(macroexpand-in
|
||||
body
|
||||
(nconc
|
||||
(map (lambda (bind)
|
||||
(list (car bind)
|
||||
(macroexpand-in (cadr bind) env)
|
||||
env))
|
||||
binds)
|
||||
env))))
|
||||
(else
|
||||
(map (lambda (x) (macroexpand-in x env)) e)))))))))
|
||||
|
||||
(define (delete-duplicates lst)
|
||||
(if (atom? lst)
|
||||
lst
|
||||
(let ((elt (car lst))
|
||||
(tail (cdr lst)))
|
||||
(if (member elt tail)
|
||||
(delete-duplicates tail)
|
||||
(cons elt
|
||||
(delete-duplicates tail))))))
|
||||
|
||||
(define (get-defined-vars- expr)
|
||||
(cond ((atom? expr) ())
|
||||
((and (eq? (car expr) 'define)
|
||||
(pair? (cdr expr)))
|
||||
(or (and (symbol? (cadr expr))
|
||||
(list (cadr expr)))
|
||||
(and (pair? (cadr expr))
|
||||
(symbol? (caadr expr))
|
||||
(list (caadr expr)))
|
||||
()))
|
||||
((eq? (car expr) 'begin)
|
||||
(apply append (map get-defined-vars- (cdr expr))))
|
||||
(else ())))
|
||||
(define (get-defined-vars expr)
|
||||
(delete-duplicates (get-defined-vars- expr)))
|
||||
|
||||
; redefine f-body to support internal defines
|
||||
(define f-body- f-body)
|
||||
(define (f-body e)
|
||||
((lambda (B)
|
||||
((lambda (V)
|
||||
(if (null? V)
|
||||
B
|
||||
(cons (list 'lambda V B) (map (lambda (x) #f) V))))
|
||||
(get-defined-vars B)))
|
||||
(f-body- e)))
|
||||
|
||||
(define-macro (body . forms) (f-body forms))
|
||||
|
||||
(define (expand x) (macroexpand x))
|
||||
|
||||
(define = eqv?)
|
||||
(define (/= a b) (not (eqv? a b)))
|
||||
(define (> a b) (< b a))
|
||||
|
|
@ -188,17 +96,26 @@
|
|||
(define (abs x) (if (< x 0) (- x) x))
|
||||
(define (identity x) x)
|
||||
(define (char? x) (eq? (typeof x) 'wchar))
|
||||
(define (function? x)
|
||||
(or (builtin? x)
|
||||
(and (pair? x) (eq (car x) 'lambda))))
|
||||
(define procedure? function?)
|
||||
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
(define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
|
||||
; list utilities --------------------------------------------------------------
|
||||
|
||||
(define (every pred lst)
|
||||
(or (atom? lst)
|
||||
|
|
@ -250,6 +167,11 @@
|
|||
(#t (last (cdr l)))))
|
||||
(define last-pair last)
|
||||
|
||||
(define (to-proper l)
|
||||
(cond ((null? l) l)
|
||||
((atom? l) (list l))
|
||||
(else (cons (car l) (to-proper (cdr l))))))
|
||||
|
||||
(define (map! f lst)
|
||||
(prog1 lst
|
||||
(while (pair? lst)
|
||||
|
|
@ -283,6 +205,10 @@
|
|||
(#t
|
||||
(separate- pred (cdr lst) yes (cons (car lst) no)))))
|
||||
|
||||
(define (nestlist f zero n)
|
||||
(if (<= n 0) ()
|
||||
(cons zero (nestlist f (f zero) (- n 1)))))
|
||||
|
||||
(define (foldr f zero lst)
|
||||
(if (null? lst) zero
|
||||
(f (car lst) (foldr f zero (cdr lst)))))
|
||||
|
|
@ -310,36 +236,54 @@
|
|||
(set! prev l))))))
|
||||
prev))
|
||||
|
||||
(define-macro (let* binds . body)
|
||||
(cons (list 'lambda (map car binds)
|
||||
(f-body
|
||||
(nconc (map (lambda (b) (cons 'set! b)) binds)
|
||||
body)))
|
||||
(map (lambda (x) #f) binds)))
|
||||
(set-syntax! 'letrec (symbol-syntax 'let*))
|
||||
(define (delete-duplicates lst)
|
||||
(if (atom? lst)
|
||||
lst
|
||||
(let ((elt (car lst))
|
||||
(tail (cdr lst)))
|
||||
(if (member elt tail)
|
||||
(delete-duplicates tail)
|
||||
(cons elt
|
||||
(delete-duplicates tail))))))
|
||||
|
||||
(define-macro (when c . body) (list 'if c (f-body body) #f))
|
||||
(define-macro (unless c . body) (list 'if c #f (f-body body)))
|
||||
(define (get-defined-vars- expr)
|
||||
(cond ((atom? expr) ())
|
||||
((and (eq? (car expr) 'define)
|
||||
(pair? (cdr expr)))
|
||||
(or (and (symbol? (cadr expr))
|
||||
(list (cadr expr)))
|
||||
(and (pair? (cadr expr))
|
||||
(symbol? (caadr expr))
|
||||
(list (caadr expr)))
|
||||
()))
|
||||
((eq? (car expr) 'begin)
|
||||
(apply append (map get-defined-vars- (cdr expr))))
|
||||
(else ())))
|
||||
(define (get-defined-vars expr)
|
||||
(delete-duplicates (get-defined-vars- expr)))
|
||||
|
||||
; redefine f-body to support internal define
|
||||
(define f-body- f-body)
|
||||
(define (f-body e)
|
||||
((lambda (B)
|
||||
((lambda (V)
|
||||
(if (null? V)
|
||||
B
|
||||
(cons (list 'lambda V B) (map (lambda (x) #f) V))))
|
||||
(get-defined-vars B)))
|
||||
(f-body- e)))
|
||||
|
||||
; backquote -------------------------------------------------------------------
|
||||
|
||||
(define (revappend l1 l2) (nconc (reverse l1) l2))
|
||||
(define (nreconc l1 l2) (nconc (nreverse l1) l2))
|
||||
|
||||
(define (list->vector l) (apply vector l))
|
||||
(define (vector->list v)
|
||||
(let ((n (length v))
|
||||
(l ()))
|
||||
(for 1 n
|
||||
(lambda (i)
|
||||
(set! l (cons (aref v (- n i)) l))))
|
||||
l))
|
||||
|
||||
(define (self-evaluating? x)
|
||||
(or (and (atom? x)
|
||||
(not (symbol? x)))
|
||||
(and (constant? x)
|
||||
(eq x (eval x)))))
|
||||
|
||||
; backquote
|
||||
(define-macro (backquote x) (bq-process x))
|
||||
|
||||
(define (splice-form? x)
|
||||
|
|
@ -390,11 +334,24 @@
|
|||
(cadr x)
|
||||
(bq-process x)))
|
||||
|
||||
; standard macros -------------------------------------------------------------
|
||||
|
||||
(define (quote-value v)
|
||||
(if (self-evaluating? v)
|
||||
v
|
||||
(list 'quote v)))
|
||||
|
||||
(define-macro (let* binds . body)
|
||||
(cons (list 'lambda (map car binds)
|
||||
(f-body
|
||||
(nconc (map (lambda (b) (cons 'set! b)) binds)
|
||||
body)))
|
||||
(map (lambda (x) #f) binds)))
|
||||
(set-syntax! 'letrec (symbol-syntax 'let*))
|
||||
|
||||
(define-macro (when c . body) (list 'if c (f-body body) #f))
|
||||
(define-macro (unless c . body) (list 'if c #f (f-body body)))
|
||||
|
||||
(define-macro (case key . clauses)
|
||||
(define (vals->cond key v)
|
||||
(cond ((eq? v 'else) 'else)
|
||||
|
|
@ -455,6 +412,8 @@
|
|||
(for-each f (cdr l)))
|
||||
#t))
|
||||
|
||||
; exceptions ------------------------------------------------------------------
|
||||
|
||||
(define (error . args) (raise (cons 'error args)))
|
||||
|
||||
(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
|
||||
|
|
@ -473,16 +432,34 @@
|
|||
(lambda (,e) (begin ,finally (raise ,e))))
|
||||
,finally)))
|
||||
|
||||
(if (or (eq? *os-name* 'win32)
|
||||
(eq? *os-name* 'win64)
|
||||
(eq? *os-name* 'windows))
|
||||
(begin (define *directory-separator* "\\")
|
||||
(define *linefeed* "\r\n"))
|
||||
(begin (define *directory-separator* "/")
|
||||
(define *linefeed* "\n")))
|
||||
; debugging utilities ---------------------------------------------------------
|
||||
|
||||
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
|
||||
|
||||
(define (trace sym)
|
||||
(let* ((lam (eval sym))
|
||||
(args (cadr lam))
|
||||
(al (to-proper args)))
|
||||
(if (not (eq? (car lam) 'trace-lambda))
|
||||
(set sym
|
||||
`(trace-lambda ,args
|
||||
(begin
|
||||
(princ "(")
|
||||
(print ',sym)
|
||||
,@(map (lambda (a)
|
||||
`(begin (princ " ")
|
||||
(print ,a)))
|
||||
al)
|
||||
(princ ")\n")
|
||||
(',lam ,@al))))))
|
||||
'ok)
|
||||
|
||||
(define (untrace sym)
|
||||
(let ((lam (eval sym)))
|
||||
(if (eq? (car lam) 'trace-lambda)
|
||||
(set sym
|
||||
(cadr (caar (last (caddr lam))))))))
|
||||
|
||||
(define-macro (time expr)
|
||||
(let ((t0 (gensym)))
|
||||
`(let ((,t0 (time.now)))
|
||||
|
|
@ -490,10 +467,38 @@
|
|||
,expr
|
||||
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
|
||||
|
||||
; text I/O --------------------------------------------------------------------
|
||||
|
||||
(if (or (eq? *os-name* 'win32)
|
||||
(eq? *os-name* 'win64)
|
||||
(eq? *os-name* 'windows))
|
||||
(begin (define *directory-separator* "\\")
|
||||
(define *linefeed* "\r\n"))
|
||||
(begin (define *directory-separator* "/")
|
||||
(define *linefeed* "\n")))
|
||||
|
||||
(define *output-stream* *stdout*)
|
||||
(define *input-stream* *stdin*)
|
||||
(define (print . args) (apply io.print (cons *output-stream* args)))
|
||||
(define (princ . args) (apply io.princ (cons *output-stream* args)))
|
||||
|
||||
(define (newline) (princ *linefeed*))
|
||||
(define (display x) (princ x) #t)
|
||||
(define (println . args) (prog1 (apply print args) (newline)))
|
||||
|
||||
(define (io.readline s) (io.readuntil s #\x0a))
|
||||
|
||||
; vector functions ------------------------------------------------------------
|
||||
|
||||
(define (list->vector l) (apply vector l))
|
||||
(define (vector->list v)
|
||||
(let ((n (length v))
|
||||
(l ()))
|
||||
(for 1 n
|
||||
(lambda (i)
|
||||
(set! l (cons (aref v (- n i)) l))))
|
||||
l))
|
||||
|
||||
(define (vu8 . elts) (apply array (cons 'uint8 elts)))
|
||||
|
||||
(define (vector.map f v)
|
||||
|
|
@ -504,6 +509,8 @@
|
|||
(aset! nv i (f (aref v i)))))
|
||||
nv))
|
||||
|
||||
; table functions -------------------------------------------------------------
|
||||
|
||||
(define (table.pairs t)
|
||||
(table.foldl (lambda (k v z) (cons (cons k v) z))
|
||||
() t))
|
||||
|
|
@ -518,34 +525,19 @@
|
|||
(table.foldl (lambda (k v z) (put! nt k v))
|
||||
() t)
|
||||
nt))
|
||||
(define (table.invert t)
|
||||
(let ((nt (table)))
|
||||
(table.foldl (lambda (k v z) (put! nt v k))
|
||||
() t)
|
||||
nt))
|
||||
(define (table.foreach f t)
|
||||
(table.foldl (lambda (k v z) (begin (f k v) #t)) () t))
|
||||
|
||||
(define (load filename)
|
||||
(let ((F (file filename :read)))
|
||||
(trycatch
|
||||
(let next (prev E v)
|
||||
(if (not (io.eof? F))
|
||||
(next (read F)
|
||||
prev
|
||||
(eval (expand E)))
|
||||
(begin (io.close F)
|
||||
; evaluate last form in almost-tail position
|
||||
(eval (expand E)))))
|
||||
(lambda (e)
|
||||
(begin
|
||||
(io.close F)
|
||||
(raise `(load-error ,filename ,e)))))))
|
||||
; string functions ------------------------------------------------------------
|
||||
|
||||
(define (string.tail s n)
|
||||
(string.sub s (string.inc s 0 n) (sizeof s)))
|
||||
|
||||
(define *banner* (string.tail "
|
||||
; _
|
||||
; |_ _ _ |_ _ | . _ _
|
||||
; | (-||||_(_)|__|_)|_)
|
||||
;-------------------|----------------------------------------------------------
|
||||
|
||||
" 1))
|
||||
|
||||
(define *whitespace*
|
||||
(string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
|
||||
8193 8194 8195 8196 8197 8198 8199 8200
|
||||
|
|
@ -576,12 +568,89 @@
|
|||
(set! i (#.string.inc s i)))))
|
||||
(io.tostring! b)))
|
||||
|
||||
(define (string.rep s k)
|
||||
(cond ((< k 4)
|
||||
(cond ((<= k 0) "")
|
||||
((= k 1) (string s))
|
||||
((= k 2) (string s s))
|
||||
(else (string s s s))))
|
||||
((odd? k) (string s (string.rep s (- k 1))))
|
||||
(else (string.rep (string s s) (/ k 2)))))
|
||||
|
||||
(define (pad-l s n c) (string (string.rep c (- n (length s))) s))
|
||||
(define (pad-r s n c) (string s (string.rep c (- n (length s)))))
|
||||
|
||||
(define (print-to-string v)
|
||||
(let ((b (buffer)))
|
||||
(io.print b v)
|
||||
(io.tostring! b)))
|
||||
|
||||
(define (io.readline s) (io.readuntil s #byte(0xA)))
|
||||
; toplevel --------------------------------------------------------------------
|
||||
|
||||
(define (macrocall? e) (and (symbol? (car e))
|
||||
(symbol-syntax (car e))))
|
||||
|
||||
(define (macroexpand-1 e)
|
||||
(if (atom? e) e
|
||||
(let ((f (macrocall? e)))
|
||||
(if f (apply f (cdr e))
|
||||
e))))
|
||||
|
||||
(define (macroexpand e) (macroexpand-in e ()))
|
||||
|
||||
(define (macroexpand-in e env)
|
||||
(if (atom? e) e
|
||||
(let ((f (assq (car e) env)))
|
||||
(if f
|
||||
(macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
|
||||
(let ((f (macrocall? e)))
|
||||
(if f
|
||||
(macroexpand-in (apply f (cdr e)) env)
|
||||
(cond ((eq (car e) 'quote) e)
|
||||
((eq (car e) 'lambda)
|
||||
(nlist* 'lambda (cadr e)
|
||||
(macroexpand-in (caddr e) env)
|
||||
(cdddr e)))
|
||||
((eq (car e) 'let-syntax)
|
||||
(let ((binds (cadr e))
|
||||
(body (f-body (cddr e))))
|
||||
(macroexpand-in
|
||||
body
|
||||
(nconc
|
||||
(map (lambda (bind)
|
||||
(list (car bind)
|
||||
(macroexpand-in (cadr bind) env)
|
||||
env))
|
||||
binds)
|
||||
env))))
|
||||
(else
|
||||
(map (lambda (x) (macroexpand-in x env)) e)))))))))
|
||||
|
||||
(define (expand x) (macroexpand x))
|
||||
|
||||
(define (load filename)
|
||||
(let ((F (file filename :read)))
|
||||
(trycatch
|
||||
(let next (prev E v)
|
||||
(if (not (io.eof? F))
|
||||
(next (read F)
|
||||
prev
|
||||
(eval (expand E)))
|
||||
(begin (io.close F)
|
||||
; evaluate last form in almost-tail position
|
||||
(eval (expand E)))))
|
||||
(lambda (e)
|
||||
(begin
|
||||
(io.close F)
|
||||
(raise `(load-error ,filename ,e)))))))
|
||||
|
||||
(define *banner* (string.tail "
|
||||
; _
|
||||
; |_ _ _ |_ _ | . _ _
|
||||
; | (-||||_(_)|__|_)|_)
|
||||
;-------------------|----------------------------------------------------------
|
||||
|
||||
" 1))
|
||||
|
||||
(define (repl)
|
||||
(define (prompt)
|
||||
|
|
|
|||
Loading…
Reference in New Issue