ref: e3158b86408ec68c0e41e7074a4a9c94f445e3d6
parent: c076be667bfd617bf0cfe8e9ea690a1632651c38
author: JeffBezanson <[email protected]>
date: Sat Mar 28 17:39:04 EDT 2009
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
--- /dev/null
+++ b/femtolisp/compiler.lsp
@@ -1,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
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -302,6 +302,8 @@
* 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
--- a/femtolisp/rule30.lsp
+++ b/femtolisp/rule30.lsp
@@ -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))
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -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,18 +96,27 @@
(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)
(and (pred (car 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,29 +236,48 @@
(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)))
@@ -339,7 +284,6 @@
(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)