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

moving implementation of startup, repl, load, and top-level 

exception handler into system.lsp

adding several iostream functions

adding support for internal define
This commit is contained in:
JeffBezanson 2009-02-19 03:31:40 +00:00
parent 79e12b2dcb
commit 0c0471e856
7 changed files with 240 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
femtolisp/ast/rpasses.lsp
View File

@ -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

7
femtolisp/builtins.c
View File

@ -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 },

149
femtolisp/flisp.c
View File

@ -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
}
// 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);
e = read_sexpr(f);
if (ios_eof(f)) break;
v = toplevel_eval(e);
}
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);
}
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;
}

50
femtolisp/iostream.c
View File

@ -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 }
};

137
femtolisp/system.lsp
View File

@ -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,14 +328,15 @@
(define-macro (let* binds . body)
(cons (list 'lambda (map car binds)
(cons 'begin
(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
(f-body
(nconc (map (lambda (b)
(list 'set! (car b) (cons 'lambda (cdr b))))
binds)
@ -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))

17
femtolisp/todo
View File

@ -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

2
llt/ios.c
View File

@ -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)