lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
JeffBezanson 2009-08-08 00:29:55 +00:00
parent c6a977063e
commit 1a6d9d391f
5 changed files with 81 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

2
femtolisp/flisp.c
View File

@ -1962,6 +1962,8 @@ static value_t fl_function(value_t *args, uint32_t nargs)
fn->name = args[3]; fn->name = args[3];
} }
} }
if (isgensym(fn->name))
lerror(ArgError, "function: name should not be a gensym");
} }
return fv; return fv;
} }

34
femtolisp/iostream.c
View File

@ -179,28 +179,17 @@ value_t fl_iopos(value_t *args, u_int32_t nargs)
return size_wrap((size_t)res); 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) if (nargs < 1 || nargs > 2)
argcount(fname, nargs, 2); argcount("write", nargs, 1);
ios_t *s = toiostream(args[0], fname); ios_t *s;
unsigned i; if (nargs == 2)
for (i=1; i < nargs; i++) { s = toiostream(args[1], "write");
print(s, args[i]); else
} s = toiostream(symbol_value(outstrsym), "write");
} print(s, args[0]);
value_t fl_ioprint(value_t *args, u_int32_t nargs) return args[0];
{
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) value_t fl_ioread(value_t *args, u_int32_t nargs)
@ -344,8 +333,7 @@ static builtinspec_t iostreamfunc_info[] = {
{ "file", fl_file }, { "file", fl_file },
{ "buffer", fl_buffer }, { "buffer", fl_buffer },
{ "read", fl_read }, { "read", fl_read },
{ "io.print", fl_ioprint }, { "write", fl_write },
{ "io.princ", fl_ioprinc },
{ "io.flush", fl_ioflush }, { "io.flush", fl_ioflush },
{ "io.close", fl_ioclose }, { "io.close", fl_ioclose },
{ "io.eof?" , fl_ioeof }, { "io.eof?" , fl_ioeof },

103
femtolisp/system.lsp
View File

@ -436,6 +436,16 @@
(for-each f (cdr l))) (for-each f (cdr l)))
#t)) #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 ------------------------------------------------------------------ ; exceptions ------------------------------------------------------------------
(define (error . args) (raise (cons 'error args))) (define (error . args) (raise (cons 'error args)))
@ -495,8 +505,10 @@
; text I/O -------------------------------------------------------------------- ; text I/O --------------------------------------------------------------------
(define (print . args) (apply io.print *output-stream* args)) (define (print . args) (for-each write args))
(define (princ . args) (apply io.princ *output-stream* args)) (define (princ . args)
(with-bindings ((*print-readably* #f))
(for-each write args)))
(define (newline) (princ *linefeed*) #t) (define (newline) (princ *linefeed*) #t)
(define (display x) (princ x) #t) (define (display x) (princ x) #t)
@ -515,6 +527,17 @@
(define (io.readlines s) (read-all-of io.readline s)) (define (io.readlines s) (read-all-of io.readline s))
(define (read-all s) (read-all-of read 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 ------------------------------------------------------------ ; vector functions ------------------------------------------------------------
(define (list->vector l) (apply vector l)) (define (list->vector l) (apply vector l))
@ -606,7 +629,7 @@
(define (print-to-string v) (define (print-to-string v)
(let ((b (buffer))) (let ((b (buffer)))
(io.print b v) (write v b)
(io.tostring! b))) (io.tostring! b)))
(define (string.join strlist sep) (define (string.join strlist sep)
@ -708,14 +731,18 @@
(define (reploop) (define (reploop)
(when (trycatch (and (prompt) (newline)) (when (trycatch (and (prompt) (newline))
(lambda (e) (lambda (e)
(print-exception e) (top-level-exception-handler e)
(print-stack-trace (stacktrace))
#t)) #t))
(begin (newline) (begin (newline)
(reploop)))) (reploop))))
(reploop) (reploop)
(newline)) (newline))
(define (top-level-exception-handler e)
(with-output-to *stderr*
(print-exception e)
(print-stack-trace (stacktrace))))
(define (print-stack-trace st) (define (print-stack-trace st)
(define (find-in-f f tgt path) (define (find-in-f f tgt path)
(let ((path (cons (function:name f) path))) (let ((path (cons (function:name f) path)))
@ -750,48 +777,46 @@
st))) st)))
(define (print-exception e) (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) (cond ((and (pair? e)
(eq? (car e) 'type-error) (eq? (car e) 'type-error)
(length= e 4)) (length= e 4))
(eprinc "type error: " (cadr e) ": expected " (caddr e) ", got ") (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
(eprint (cadddr e))) (print (cadddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'bounds-error) (eq? (car e) 'bounds-error)
(length= e 4)) (length= e 4))
(eprinc (cadr e) ": index " (cadddr e) " out of bounds for ") (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
(eprint (caddr e))) (print (caddr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'unbound-error) (eq? (car e) 'unbound-error)
(pair? (cdr e))) (pair? (cdr e)))
(eprinc "eval: variable " (cadr e) " has no value")) (princ "eval: variable " (cadr e) " has no value"))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'error)) (eq? (car e) 'error))
(eprinc "error: ") (princ "error: ")
(apply eprinc (cdr e))) (apply princ (cdr e)))
((and (pair? e) ((and (pair? e)
(eq? (car e) 'load-error)) (eq? (car e) 'load-error))
(print-exception (caddr e)) (print-exception (caddr e))
(eprinc "in file " (cadr e))) (princ "in file " (cadr e)))
((and (list? e) ((and (list? e)
(length= e 2)) (length= e 2))
(eprint (car e)) (print (car e))
(eprinc ": ") (princ ": ")
(let ((msg (cadr e))) (let ((msg (cadr e)))
((if (or (string? msg) (symbol? msg)) ((if (or (string? msg) (symbol? msg))
eprinc eprint) princ print)
msg))) msg)))
(else (eprinc "*** Unhandled exception: ") (else (princ "*** Unhandled exception: ")
(eprint e))) (print e)))
(eprinc *linefeed*)) (princ *linefeed*))
(define (simple-sort l) (define (simple-sort l)
(if (or (null? l) (null? (cdr l))) l (if (or (null? l) (null? (cdr l))) l
@ -804,24 +829,22 @@
(define (make-system-image fname) (define (make-system-image fname)
(let ((f (file fname :write :create :truncate)) (let ((f (file fname :write :create :truncate))
(excludes '(*linefeed* *directory-separator* *argv* that (excludes '(*linefeed* *directory-separator* *argv* that
*print-pretty* *print-width* *print-readably*)) *print-pretty* *print-width* *print-readably*)))
(pp *print-pretty*)) (with-bindings ((*print-pretty* #f)
(set! *print-pretty* #f) (*print-readably* #t))
(unwind-protect (let ((syms
(let ((syms (filter (lambda (s) (filter (lambda (s)
(and (bound? s) (and (bound? s)
(not (constant? s)) (not (constant? s))
(or (not (builtin? (top-level-value s))) (or (not (builtin? (top-level-value s)))
(not (equal? (string s) ; alias of builtin (not (equal? (string s) ; alias of builtin
(string (top-level-value s))))) (string (top-level-value s)))))
(not (memq s excludes)) (not (memq s excludes))
(not (iostream? (top-level-value s))))) (not (iostream? (top-level-value s)))))
(simple-sort (environment))))) (simple-sort (environment)))))
(io.print f (apply nconc (map list syms (map top-level-value syms)))) (write (apply nconc (map list syms (map top-level-value syms))) f)
(io.write f *linefeed*)) (io.write f *linefeed*))
(begin (io.close f))))
(io.close f)
(set! *print-pretty* pp)))))
; initialize globals that need to be set at load time ; initialize globals that need to be set at load time
(define (__init_globals) (define (__init_globals)
@ -838,7 +861,7 @@
(define (__script fname) (define (__script fname)
(trycatch (load fname) (trycatch (load fname)
(lambda (e) (begin (print-exception e) (lambda (e) (begin (top-level-exception-handler e)
(exit 1))))) (exit 1)))))
(define (__start argv) (define (__start argv)

7
femtolisp/todo
View File

@ -31,7 +31,7 @@
* fix printing nan and inf * fix printing nan and inf
* move to "2.5-bit" type tags * move to "2.5-bit" type tags
? builtin abs() ? 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 is acceptable
* (syntax-environment) to return it as an assoc list * (syntax-environment) to return it as an assoc list
* (environment) for variables, constantp * (environment) for variables, constantp
@ -110,7 +110,6 @@ possible optimizations:
* represent lambda environment as a vector (in lispv) * represent lambda environment as a vector (in lispv)
x setq builtin (didn't help) x setq builtin (didn't help)
* list builtin, to use cons_reserve * list builtin, to use cons_reserve
(- let builtin, to further avoid env consing)
unconventional interpreter builtins that can be used as a compilation unconventional interpreter builtins that can be used as a compilation
target without moving away from s-expressions: target without moving away from s-expressions:
- (*global* . a) ; special form, don't look in local env first - (*global* . a) ; special form, don't look in local env first
@ -139,6 +138,7 @@ for internal use:
. and/or add function array.alloc . and/or add function array.alloc
x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?) x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
. this made no difference in a string.map microbenchmark . this made no difference in a string.map microbenchmark
- use faster hash/compare in tables where the keys are eq-comparable
bugs: bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains * with the fully recursive (simpler) relocate(), the size of cons chains
@ -976,7 +976,7 @@ consolidated todo list as of 7/8:
- remaining cvalues functions - remaining cvalues functions
- finish ios - finish ios
* optional arguments * optional arguments
- keyword arguments * keyword arguments
- some kind of record, struct, or object system - some kind of record, struct, or object system
- special efficient reader for #array - special efficient reader for #array
@ -1169,3 +1169,4 @@ what needs more test coverage:
- typeof, copy, podp, builtin() - typeof, copy, podp, builtin()
- bitwise and logical ops - bitwise and logical ops
- making a closure in a default value expression for an optional arg - making a closure in a default value expression for an optional arg
- gc during a catch block, then get stack trace