ref: 1a6d9d391fd84f37656ec2abefe3f5736cd742b9
parent: c6a977063e97d4d1a9b4c07d2e0c7d0ceb02a6c0
author: JeffBezanson <[email protected]>
date: Fri Aug 7 20:29:55 EDT 2009
adding with-bindings, with-output-to-file, with-output-to simplifying printing. now based on standard function write, removing io.print and io.princ using same top level exception handler for scripts as repl
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(assert #function("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) letrec #function("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0|41;" [bq-process]) label #function(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #function("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#function("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #function("<000s1c0|c1}K^L4;" [if begin]) unwind-protect #function("8000r2c0qe130e13042;" [#function("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function(";000s1c0q|M|\x8442;" [#function("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) define-macro #function("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0|^c1}KL4;" [if begin]) let #function(":000s1c0q^41;" [#function("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#function("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #function("6000r1|F650|M;|;" []) copy-list #function("6000r1|F650|\x84;^;" [])])]) cond #function("9000s0c0q^41;" [#function("7000r1c0qm02|~41;" [#function("7000r1|?640^;c0q|M41;" [#function(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #function("7000r1c0qe13041;" [#function(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #function(":000s1c0q^41;" [#function("7000r1c0m02c1qe23041;" [#function(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10~|M32|NK;" [])]) gensym])]) catch #function("7000r2c0qe13041;" [#function("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2|}W@;" [] /=) 1+ #function("7000r1|aw;" [] 1+) 1- #function("7000r1|ax;" [] 1-) 1arg-lambda? #function("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2|}X17602|}W;" [] <=) > #function("7000r2}|X;" [] >) >= #function("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dumm\ No newline at end of file
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(with-bindings #function(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#function("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc let map #.list copy-list #function("8000r2c0|}L3;" [set!]) unwind-protect begin #function("8000r2c0|}L3;" [set!])]) map #.car cadr #function("6000r1e040;" [gensym])]) letrec #function("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0|41;" [bq-process]) assert #function("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) label #function(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #function("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#function("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #function("<000s1c0|c1}K^L4;" [if begin]) dotimes #function(";000s1c0q|M|\x8442;" [#function("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) unwind-protect #function("8000r2c0qe130e13042;" [#function("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #function("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0|^c1}KL4;" [if begin]) let #function(":000s1c0q^41;" [#function("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#function("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #function("6000r1|F650|M;|;" []) copy-list #function("6000r1|F650|\x84;^;" [])])]) cond #function("9000s0c0q^41;" [#function("7000r1c0qm02|~41;" [#function("7000r1|?640^;c0q|M41;" [#function(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #function("7000r1c0qe13041;" [#function(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #function(":000s1c0q^41;" [#function("7000r1c0m02c1qe23041;" [#function(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10~|M32|NK;" [])]) gensym])]) with-output-to #function("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *output-stream* copy-list]) catch #function("7000r2c0qe13041;" [#function("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2|}W@;" [] /=) 1+ #function("7000r1|aw;" [] 1+) 1- #function("7000r1|ax;" [] 1-) 1arg-lambda? #function("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2|}X17602|}W;" [] <=) > #function("7000r2}|X;" [] >) >= #function("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vecto\ No newline at end of file
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1962,6 +1962,8 @@
fn->name = args[3];
}
}
+ if (isgensym(fn->name))
+ lerror(ArgError, "function: name should not be a gensym");
}
return fv;
}
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -179,29 +179,18 @@
return size_wrap((size_t)res);
}
-static void do_ioprint(value_t *args, u_int32_t nargs, char *fname)
+value_t fl_write(value_t *args, u_int32_t nargs)
{- if (nargs < 2)
- argcount(fname, nargs, 2);
- ios_t *s = toiostream(args[0], fname);
- unsigned i;
- for (i=1; i < nargs; i++) {- print(s, args[i]);
- }
+ if (nargs < 1 || nargs > 2)
+ argcount("write", nargs, 1);+ ios_t *s;
+ if (nargs == 2)
+ s = toiostream(args[1], "write");
+ else
+ s = toiostream(symbol_value(outstrsym), "write");
+ print(s, args[0]);
+ return args[0];
}
-value_t fl_ioprint(value_t *args, u_int32_t nargs)
-{- do_ioprint(args, nargs, "io.print");
- return args[nargs-1];
-}
-value_t fl_ioprinc(value_t *args, u_int32_t nargs)
-{- value_t oldpr = symbol_value(printreadablysym);
- set(printreadablysym, FL_F);
- do_ioprint(args, nargs, "io.princ");
- set(printreadablysym, oldpr);
- return args[nargs-1];
-}
value_t fl_ioread(value_t *args, u_int32_t nargs)
{@@ -344,8 +333,7 @@
{ "file", fl_file }, { "buffer", fl_buffer }, { "read", fl_read },- { "io.print", fl_ioprint },- { "io.princ", fl_ioprinc },+ { "write", fl_write }, { "io.flush", fl_ioflush }, { "io.close", fl_ioclose }, { "io.eof?" , fl_ioeof },--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -436,6 +436,16 @@
(for-each f (cdr l)))
#t))
+(define-macro (with-bindings binds . body)
+ (let ((vars (map car binds))
+ (vals (map cadr binds))
+ (olds (map (lambda (x) (gensym)) binds)))
+ `(let ,(map list olds vars)
+ ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
+ (unwind-protect
+ (begin ,@body)
+ (begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
+
; exceptions ------------------------------------------------------------------
(define (error . args) (raise (cons 'error args)))
@@ -495,8 +505,10 @@
; text I/O --------------------------------------------------------------------
-(define (print . args) (apply io.print *output-stream* args))
-(define (princ . args) (apply io.princ *output-stream* args))
+(define (print . args) (for-each write args))
+(define (princ . args)
+ (with-bindings ((*print-readably* #f))
+ (for-each write args)))
(define (newline) (princ *linefeed*) #t)
(define (display x) (princ x) #t)
@@ -515,6 +527,17 @@
(define (io.readlines s) (read-all-of io.readline s))
(define (read-all s) (read-all-of read s))
+(define-macro (with-output-to stream . body)
+ `(with-bindings ((*output-stream* ,stream))
+ ,@body))
+
+(define (with-output-to-file name thunk)
+ (let ((f (file name :write :create :truncate)))
+ (unwind-protect
+ (with-bindings ((*output-stream* f))
+ (thunk))
+ (io.close f))))
+
; vector functions ------------------------------------------------------------
(define (list->vector l) (apply vector l))
@@ -606,7 +629,7 @@
(define (print-to-string v)
(let ((b (buffer)))
- (io.print b v)
+ (write v b)
(io.tostring! b)))
(define (string.join strlist sep)
@@ -708,8 +731,7 @@
(define (reploop)
(when (trycatch (and (prompt) (newline))
(lambda (e)
- (print-exception e)
- (print-stack-trace (stacktrace))
+ (top-level-exception-handler e)
#t))
(begin (newline)
(reploop))))
@@ -716,6 +738,11 @@
(reploop)
(newline))
+(define (top-level-exception-handler e)
+ (with-output-to *stderr*
+ (print-exception e)
+ (print-stack-trace (stacktrace))))
+
(define (print-stack-trace st)
(define (find-in-f f tgt path)
(let ((path (cons (function:name f) path)))
@@ -750,48 +777,46 @@
st)))
(define (print-exception e)
- (define (eprinc . args) (apply io.princ *error-stream* args))
- (define (eprint . args) (apply io.print *error-stream* args))
(cond ((and (pair? e)
(eq? (car e) 'type-error)
(length= e 4))
- (eprinc "type error: " (cadr e) ": expected " (caddr e) ", got ")
- (eprint (cadddr e)))
+ (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
+ (print (cadddr e)))
((and (pair? e)
(eq? (car e) 'bounds-error)
(length= e 4))
- (eprinc (cadr e) ": index " (cadddr e) " out of bounds for ")
- (eprint (caddr e)))
+ (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
+ (print (caddr e)))
((and (pair? e)
(eq? (car e) 'unbound-error)
(pair? (cdr e)))
- (eprinc "eval: variable " (cadr e) " has no value"))
+ (princ "eval: variable " (cadr e) " has no value"))
((and (pair? e)
(eq? (car e) 'error))
- (eprinc "error: ")
- (apply eprinc (cdr e)))
+ (princ "error: ")
+ (apply princ (cdr e)))
((and (pair? e)
(eq? (car e) 'load-error))
(print-exception (caddr e))
- (eprinc "in file " (cadr e)))
+ (princ "in file " (cadr e)))
((and (list? e)
(length= e 2))
- (eprint (car e))
- (eprinc ": ")
+ (print (car e))
+ (princ ": ")
(let ((msg (cadr e)))
((if (or (string? msg) (symbol? msg))
- eprinc eprint)
+ princ print)
msg)))
- (else (eprinc "*** Unhandled exception: ")
- (eprint e)))
+ (else (princ "*** Unhandled exception: ")
+ (print e)))
- (eprinc *linefeed*))
+ (princ *linefeed*))
(define (simple-sort l)
(if (or (null? l) (null? (cdr l))) l
@@ -804,24 +829,22 @@
(define (make-system-image fname)
(let ((f (file fname :write :create :truncate))
(excludes '(*linefeed* *directory-separator* *argv* that
- *print-pretty* *print-width* *print-readably*))
- (pp *print-pretty*))
- (set! *print-pretty* #f)
- (unwind-protect
- (let ((syms (filter (lambda (s)
- (and (bound? s)
- (not (constant? s))
- (or (not (builtin? (top-level-value s)))
- (not (equal? (string s) ; alias of builtin
- (string (top-level-value s)))))
- (not (memq s excludes))
- (not (iostream? (top-level-value s)))))
- (simple-sort (environment)))))
- (io.print f (apply nconc (map list syms (map top-level-value syms))))
- (io.write f *linefeed*))
- (begin
- (io.close f)
- (set! *print-pretty* pp)))))
+ *print-pretty* *print-width* *print-readably*)))
+ (with-bindings ((*print-pretty* #f)
+ (*print-readably* #t))
+ (let ((syms
+ (filter (lambda (s)
+ (and (bound? s)
+ (not (constant? s))
+ (or (not (builtin? (top-level-value s)))
+ (not (equal? (string s) ; alias of builtin
+ (string (top-level-value s)))))
+ (not (memq s excludes))
+ (not (iostream? (top-level-value s)))))
+ (simple-sort (environment)))))
+ (write (apply nconc (map list syms (map top-level-value syms))) f)
+ (io.write f *linefeed*))
+ (io.close f))))
; initialize globals that need to be set at load time
(define (__init_globals)
@@ -838,7 +861,7 @@
(define (__script fname)
(trycatch (load fname)
- (lambda (e) (begin (print-exception e)
+ (lambda (e) (begin (top-level-exception-handler e)
(exit 1)))))
(define (__start argv)
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -31,7 +31,7 @@
* fix printing nan and inf
* move to "2.5-bit" type tags
? builtin abs()
-- try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
+* try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
is acceptable
* (syntax-environment) to return it as an assoc list
* (environment) for variables, constantp
@@ -110,7 +110,6 @@
* represent lambda environment as a vector (in lispv)
x setq builtin (didn't help)
* list builtin, to use cons_reserve
-(- let builtin, to further avoid env consing)
unconventional interpreter builtins that can be used as a compilation
target without moving away from s-expressions:
- (*global* . a) ; special form, don't look in local env first
@@ -139,6 +138,7 @@
. and/or add function array.alloc
x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
. this made no difference in a string.map microbenchmark
+- use faster hash/compare in tables where the keys are eq-comparable
bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains
@@ -976,7 +976,7 @@
- remaining cvalues functions
- finish ios
* optional arguments
-- keyword arguments
+* keyword arguments
- some kind of record, struct, or object system
- special efficient reader for #array
@@ -1169,3 +1169,4 @@
- typeof, copy, podp, builtin()
- bitwise and logical ops
- making a closure in a default value expression for an optional arg
+- gc during a catch block, then get stack trace