ref: 0c0471e85605e670aab34592cd69cf3f922afd1b
parent: 79e12b2dcbe71f78a6c93656a2e440ca09595913
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Feb 18 22:31:40 EST 2009
moving implementation of startup, repl, load, and top-level exception handler into system.lsp adding several iostream functions adding support for internal define
--- a/femtolisp/ast/rpasses.lsp
+++ b/femtolisp/ast/rpasses.lsp
@@ -20,8 +20,9 @@
; transformations
(let ((ctr 0))
- (define (r-gensym) (prog1 (intern (string "%r:" ctr))
- (set! ctr (+ ctr 1)))))
+ (set! r-gensym (lambda ()
+ (prog1 (intern (string "%r:" ctr))
+ (set! ctr (+ ctr 1))))))
(define (dollarsign-transform e)
(pattern-expand
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -35,12 +35,6 @@
return NIL;
}
-value_t fl_load(value_t *args, u_int32_t nargs)
-{- argcount("load", nargs, 1);- return load_file(tostring(args[0], "load"));
-}
-
value_t fl_exit(value_t *args, u_int32_t nargs)
{if (nargs > 0)
@@ -375,7 +369,6 @@
{ "environment", fl_global_env }, { "constant?", fl_constantp },- { "load", fl_load }, { "exit", fl_exit }, { "intern", fl_intern }, { "fixnum", fl_fixnum },--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -111,7 +111,6 @@
static exception_context_t *ctx = NULL;
static value_t lasterror;
-static char lerrorbuf[512];
#define FL_TRY \
exception_context_t _ctx; int l__tr, l__ca; \
@@ -122,14 +121,11 @@
#define FL_CATCH \
else \
- for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL)
+ for (l__ca=1; l__ca; l__ca=0, lasterror=NIL)
void raise(value_t e)
{- if (e != lasterror) {- lasterror = e;
- lerrorbuf[0] = '\0'; // overwriting exception; clear error buf
- }
+ lasterror = e;
// unwind read state
while (readstate != ctx->rdst) {free_readstate(readstate);
@@ -142,15 +138,21 @@
longjmp(thisctx->buf, 1);
}
+static value_t make_error_msg(char *format, va_list args)
+{+ char msgbuf[512];
+ vsnprintf(msgbuf, sizeof(msgbuf), format, args);
+ return string_from_cstr(msgbuf);
+}
+
void lerror(value_t e, char *format, ...)
{va_list args;
va_start(args, format);
- vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args);
+ value_t msg = make_error_msg(format, args);
va_end(args);
- lasterror = e;
- raise(e);
+ raise(list2(e, msg));
}
void type_error(char *fname, char *expected, value_t got)
@@ -1470,7 +1472,6 @@
set(printprettysym=symbol("*print-pretty*"), FL_T); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));lasterror = NIL;
- lerrorbuf[0] = '\0';
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
i = 0;
while (isspecial(builtin(i))) {@@ -1483,13 +1484,13 @@
}
#ifdef LINUX
- set(symbol("os.name"), symbol("linux"));+ set(symbol("*os-name*"), symbol("linux"));#elif defined(WIN32) || defined(WIN64)
- set(symbol("os.name"), symbol("win32"));+ set(symbol("*os-name*"), symbol("win32"));#elif defined(MACOSX)
- set(symbol("os.name"), symbol("macos"));+ set(symbol("*os-name*"), symbol("macos"));#else
- set(symbol("os.name"), symbol("unknown"));+ set(symbol("*os-name*"), symbol("unknown"));#endif
cvalues_init();
@@ -1521,81 +1522,15 @@
return v;
}
-static void print_toplevel_exception()
-{- if (iscons(lasterror) && car_(lasterror) == TypeError &&
- llength(lasterror) == 4) {- ios_printf(ios_stderr, "type-error: ");
- print(ios_stderr, car_(cdr_(lasterror)), 1);
- ios_printf(ios_stderr, ": expected ");
- print(ios_stderr, car_(cdr_(cdr_(lasterror))), 1);
- ios_printf(ios_stderr, ", got ");
- print(ios_stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0);
- }
- else if (iscons(lasterror) && car_(lasterror) == UnboundError &&
- iscons(cdr_(lasterror))) {- ios_printf(ios_stderr, "unbound-error: eval: variable %s has no value",
- (symbol_name(car_(cdr_(lasterror)))));
- }
- else if (iscons(lasterror) && car_(lasterror) == Error) {- value_t v = cdr_(lasterror);
- ios_printf(ios_stderr, "error: ");
- while (iscons(v)) {- print(ios_stderr, car_(v), 1);
- v = cdr_(v);
- }
- }
- else {- if (lasterror != NIL) {- if (!lerrorbuf[0])
- ios_printf(ios_stderr, "*** Unhandled exception: ");
- print(ios_stderr, lasterror, 0);
- if (lerrorbuf[0])
- ios_printf(ios_stderr, ": ");
- }
- }
-
- if (lerrorbuf[0])
- ios_printf(ios_stderr, "%s", lerrorbuf);
-}
-
-value_t load_file(char *fname)
-{- value_t volatile e, v=NIL;
- ios_t fi;
- ios_t * volatile f;
- fname = strdup(fname);
- f = &fi; f = ios_file(f, fname, 1, 0, 0, 0);
- if (f == NULL) lerror(IOError, "file \"%s\" not found", fname);
- FL_TRY {- while (1) {- e = read_sexpr(f);
- //print(ios_stdout,e,0); ios_putc('\n', ios_stdout);- if (ios_eof(f)) break;
- v = toplevel_eval(e);
- }
- }
- FL_CATCH {- ios_close(f);
- size_t msglen = strlen(lerrorbuf);
- snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen,
- "\nin file \"%s\"", fname);
- lerrorbuf[sizeof(lerrorbuf)-1] = '\0';
- free(fname);
- raise(lasterror);
- }
- free(fname);
- ios_close(f);
- return v;
-}
-
static value_t argv_list(int argc, char *argv[])
{int i;
PUSH(NIL);
- if (argc > 1) { argc--; argv++; }- for(i=argc-1; i >= 0; i--)
- Stack[SP-1] = fl_cons(cvalue_static_cstring(argv[i]), Stack[SP-1]);
+ for(i=argc-1; i >= 0; i--) {+ PUSH(cvalue_static_cstring(argv[i]));
+ Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]);
+ (void)POP();
+ }
return POP();
}
@@ -1603,23 +1538,21 @@
int main(int argc, char *argv[])
{- value_t v;
+ value_t e, v;
char fname_buf[1024];
locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
lisp_init();
- set(symbol("argv"), argv_list(argc, argv));+
FL_TRY {// install toplevel exception handler
}
FL_CATCH {- print_toplevel_exception();
- lerrorbuf[0] = '\0';
- lasterror = NIL;
- ios_puts("\n\n", ios_stderr);- if (argc > 1) return 1;
- else goto repl;
+ ios_printf(ios_stderr, "fatal error during bootstrap:\n");
+ print(ios_stderr, lasterror, 0);
+ ios_putc('\n', ios_stderr);+ exit(1);
}
fname_buf[0] = '\0';
if (EXEDIR != NULL) {@@ -1627,27 +1560,19 @@
strcat(fname_buf, PATHSEPSTRING);
}
strcat(fname_buf, "system.lsp");
- load_file(fname_buf);
- if (argc > 1) { load_file(argv[1]); return 0; }- printf("; _ \n");- printf("; |_ _ _ |_ _ | . _ _\n");- printf("; | (-||||_(_)|__|_)|_)\n");- printf(";-------------------|----------------------------------------------------------\n\n");- repl:
+
+ ios_t fi;
+ ios_t *f = &fi; f = ios_file(f, fname_buf, 1, 0, 0, 0);
+ if (f == NULL) lerror(IOError, "file \"%s\" not found", fname_buf);
while (1) {- ios_puts("> ", ios_stdout); ios_flush(ios_stdout);- FL_TRY {- v = read_sexpr(ios_stdin);
- }
- FL_CATCH {- ios_purge(ios_stdin);
- raise(lasterror);
- }
- if (ios_eof(ios_stdin)) break;
- print(ios_stdout, v=toplevel_eval(v), 0);
- set(symbol("that"), v);- ios_puts("\n\n", ios_stdout);+ e = read_sexpr(f);
+ if (ios_eof(f)) break;
+ v = toplevel_eval(e);
}
- ios_putc('\n', ios_stdout);+ ios_close(f);
+
+ PUSH(symbol_value(symbol("__start")));+ PUSH(argv_list(argc, argv));
+ (void)toplevel_eval(special_apply_form);
return 0;
}
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -86,11 +86,51 @@
else
s = toiostream(symbol_value(instrsym), "read");
value_t v = read_sexpr(s);
- if (ios_eof(s))
- lerror(IOError, "read: end of file reached");
return v;
}
+value_t fl_iogetc(value_t *args, u_int32_t nargs)
+{+ argcount("io.getc", nargs, 1);+ ios_t *s = toiostream(args[0], "io.getc");
+ uint32_t wc;
+ if (ios_getutf8(s, &wc) == IOS_EOF)
+ lerror(IOError, "io.getc: end of file reached");
+ return mk_wchar(wc);
+}
+
+value_t fl_ioflush(value_t *args, u_int32_t nargs)
+{+ argcount("io.flush", nargs, 1);+ ios_t *s = toiostream(args[0], "io.flush");
+ if (ios_flush(s) != 0)
+ return FL_F;
+ return FL_T;
+}
+
+value_t fl_ioclose(value_t *args, u_int32_t nargs)
+{+ argcount("io.close", nargs, 1);+ ios_t *s = toiostream(args[0], "io.close");
+ ios_close(s);
+ return FL_T;
+}
+
+value_t fl_iopurge(value_t *args, u_int32_t nargs)
+{+ argcount("io.discardbuffer", nargs, 1);+ ios_t *s = toiostream(args[0], "io.discardbuffer");
+ ios_purge(s);
+ return FL_T;
+}
+
+value_t fl_ioeof(value_t *args, u_int32_t nargs)
+{+ argcount("io.eof?", nargs, 1);+ ios_t *s = toiostream(args[0], "io.eof?");
+ return (ios_eof(s) ? FL_T : FL_F);
+}
+
static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname)
{if (nargs < 2)
@@ -99,7 +139,6 @@
unsigned i;
for (i=1; i < nargs; i++) {print(s, args[i], princ);
- if (!princ) ios_putc('\n', s);}
}
value_t fl_ioprint(value_t *args, u_int32_t nargs)
@@ -119,6 +158,11 @@
{ "read", fl_read }, { "io.print", fl_ioprint }, { "io.princ", fl_ioprinc },+ { "io.flush", fl_ioflush },+ { "io.close", fl_ioclose },+ { "io.eof?" , fl_ioeof },+ { "io.getc" , fl_iogetc },+ { "io.discardbuffer", fl_iopurge }, { NULL, NULL }};
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -101,6 +101,43 @@
((eqv (caar lst) item) (car lst))
(#t (assv item (cdr lst)))))
+(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 (macrocall? e) (and (symbol? (car e))
(symbol-syntax (car e))))
@@ -173,6 +210,7 @@
(define (abs x) (if (< x 0) (- x) x))
(define (identity x) x)
(define K prog1) ; K combinator ;)
+(define begin0 prog1)
(define (caar x) (car (car x)))
(define (cdar x) (cdr (car x)))
@@ -290,18 +328,19 @@
(define-macro (let* binds . body)
(cons (list 'lambda (map car binds)
- (cons 'begin
- (nconc (map (lambda (b) (cons 'set! b)) binds)
- body)))
+ (f-body
+ (nconc (map (lambda (b) (cons 'set! b)) binds)
+ body)))
(map (lambda (x) #f) binds)))
+(set-syntax! 'letrec (symbol-syntax 'let*))
(define-macro (labels binds . body)
(cons (list 'lambda (map car binds)
- (cons 'begin
- (nconc (map (lambda (b)
- (list 'set! (car b) (cons 'lambda (cdr b))))
- binds)
- body)))
+ (f-body
+ (nconc (map (lambda (b)
+ (list 'set! (car b) (cons 'lambda (cdr b))))
+ binds)
+ body)))
(map (lambda (x) #f) binds)))
(define-macro (when c . body) (list 'if c (f-body body) #f))
@@ -545,3 +584,97 @@
(string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
8193 8194 8195 8196 8197 8198 8199 8200
8201 8202 8232 8233 8239 8287 12288)))
+
+(define (load filename)
+ (let ((F (file filename :read)))
+ (trycatch
+ (prog1
+ (let next (E v)
+ (if (not (io.eof? F))
+ (next (read F)
+ (eval E))
+ v))
+ (io.close F))
+ (lambda (e)
+ (begin
+ (io.close F)
+ (raise `(load-error ,filename ,e)))))))
+
+(define *banner*
+"; _
+; |_ _ _ |_ _ | . _ _
+; | (-||||_(_)|__|_)|_)
+;-------------------|----------------------------------------------------------
+
+")
+
+(define (repl)
+ (define (prompt)
+ (princ "> ") (io.flush *output-stream*)
+ (let ((v (trycatch (read)
+ (lambda (e) (begin (io.discardbuffer *input-stream*)
+ (raise e))))))
+ (and (not (io.eof? *input-stream*))
+ (let ((V (eval v)))
+ (print V)
+ (set! that V)
+ #t))))
+ (define (reploop)
+ (when (trycatch (and (prompt) (princ "\n"))
+ print-exception)
+ (begin (princ "\n")
+ (reploop))))
+ (reploop)
+ (princ "\n"))
+
+(define (print-exception e)
+ (cond ((and (pair? e)
+ (eq? (car e) 'type-error)
+ (= (length e) 4))
+ (io.princ *stderr* "type-error: ")
+ (io.print *stderr* (cadr e))
+ (io.princ *stderr* ": expected ")
+ (io.print *stderr* (caddr e))
+ (io.princ *stderr* ", got ")
+ (io.print *stderr* (cadddr e)))
+
+ ((and (pair? e)
+ (eq? (car e) 'unbound-error)
+ (pair? (cdr e)))
+ (io.princ *stderr*
+ "unbound-error: eval: variable " (cadr e)
+ " has no value"))
+
+ ((and (pair? e)
+ (eq? (car e) 'error))
+ (io.princ *stderr* "error: ")
+ (apply io.princ (cons *stderr* (cdr e))))
+
+ ((and (pair? e)
+ (eq? (car e) 'load-error))
+ (print-exception (caddr e))
+ (io.princ *stderr* "in file " (cadr e)))
+
+ ((and (list? e)
+ (= (length e) 2))
+ (io.princ *stderr* (car e) ": " (cadr e)))
+
+ (else (io.princ *stderr* "*** Unhandled exception: ")
+ (io.print *stderr* e)))
+
+ (io.princ *stderr* "\n")
+ #t)
+
+(define (__script fname)
+ (trycatch (load fname)
+ (lambda (e) (begin (print-exception e)
+ (exit 1)))))
+
+(define (__start . argv)
+ (if (pair? (cdr argv))
+ (begin (set! *argv* (cdr argv))
+ (__script (cadr argv)))
+ (begin (set! *argv* argv)
+ (princ *banner*)
+ (repl)))
+ (exit 0))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -833,22 +833,23 @@
*read - (read[ stream]) ; get next sexpr from stream
*princ
+*file
iostream - (stream[ cvalue-as-bytestream])
memstream
-*file
- io.eof
+ fifo
+ socket
+*io.eof
+*io.flush
+*io.close
+*io.discardbuffer
io.write - (io.write s cvalue)
io.read - (io.read s ctype [len])
- io.flush
- io.close
- io.pos - (io.pos s [set-pos])
- io.seek - (io.seek s offset)
io.getc - get utf8 character(s)
io.readline
io.copy - (io.copy to from [nbytes])
io.copyuntil - (io.copy to from byte)
- fifo
- socket
+ io.pos - (io.pos s [set-pos])
+ io.seek - (io.seek s offset)
io.seekend - move to end of stream
io.trunc
io.tostring! - destructively convert stringstream to string
--- a/llt/ios.c
+++ b/llt/ios.c
@@ -516,6 +516,8 @@
s->fd = -1;
if (s->buf!=NULL && s->ownbuf && s->buf!=&s->local[0])
free(s->buf);
+ s->buf = NULL;
+ s->size = s->maxsize = s->bpos = 0;
}
static void _buf_init(ios_t *s, bufmode_t bm)