diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp index 2f1dbb4..9911066 100644 --- 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 diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 9348058..0e4219d 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -35,12 +35,6 @@ value_t list_nth(value_t l, size_t n) 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 @@ static builtinspec_t builtin_info[] = { { "environment", fl_global_env }, { "constant?", fl_constantp }, - { "load", fl_load }, { "exit", fl_exit }, { "intern", fl_intern }, { "fixnum", fl_fixnum }, diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 6afb2de..2b11e49 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -111,7 +111,6 @@ typedef struct _ectx_t { 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 @@ static char lerrorbuf[512]; #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 @@ void raise(value_t e) 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 @@ void lisp_init(void) 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 @@ void lisp_init(void) } #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 @@ value_t toplevel_eval(value_t expr) 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 locale_is_utf8; 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 @@ int main(int argc, char *argv[]) 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; } diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index f7072b0..c1a0b7c 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -86,11 +86,51 @@ value_t fl_read(value_t *args, u_int32_t nargs) 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 @@ static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname) 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 @@ static builtinspec_t iostreamfunc_info[] = { { "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 } }; diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index d6fadfa..4e39da4 100644 --- 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)) diff --git a/femtolisp/todo b/femtolisp/todo index 69f3661..fad99d9 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -833,22 +833,23 @@ IOStream API *read - (read[ stream]) ; get next sexpr from stream *print *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 diff --git a/llt/ios.c b/llt/ios.c index 497cbbe..7cd4e19 100644 --- a/llt/ios.c +++ b/llt/ios.c @@ -516,6 +516,8 @@ void ios_close(ios_t *s) 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)