From 2f78b407ea3d48be3e7202fc7af2529824366d34 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Tue, 30 Jun 2009 03:21:41 +0000 Subject: [PATCH] some renaming (intern is now symbol) and moving stuff around adding scheme aliases --- femtolisp/aliases.scm | 47 +++++++++++ femtolisp/ast/asttools.lsp | 2 +- femtolisp/ast/rpasses.lsp | 2 +- femtolisp/builtins.c | 8 +- femtolisp/cps.lsp | 2 +- femtolisp/flisp.c | 162 ++++++++++++++++++------------------- 6 files changed, 133 insertions(+), 90 deletions(-) create mode 100644 femtolisp/aliases.scm diff --git a/femtolisp/aliases.scm b/femtolisp/aliases.scm new file mode 100644 index 0000000..75c2271 --- /dev/null +++ b/femtolisp/aliases.scm @@ -0,0 +1,47 @@ +; definitions of standard scheme procedures in terms of +; femtolisp procedures + +(define vector-ref aref) +(define vector-set! aset!) +(define vector-length length) +(define make-vector vector.alloc) + +(define array-ref! aref) +(define (array-set! a obj i0 . idxs) + (if (null? idxs) + (aset! a i0 obj) + (error "array-set!: multiple dimensions not yet implemented"))) + +(define (array-dimensions a) + (list (length a))) + +(define (complex? x) #f) +(define (real? x) (number? x)) +(define (rational? x) (integer? x)) +(define (exact? x) (integer? x)) +(define (inexact? x) (not (exact? x))) +(define quotient div0) + +(define (char->integer c) (fixnum c)) +(define (integer->char i) (wchar i)) +(define char-upcase char.upcase) +(define char-downcase char.downcase) +(define char=? =) +(define char? >) +(define char<=? <=) +(define char>=? >=) + +(define string=? =) +(define string? >) +(define string<=? <=) +(define string>=? >=) +(define string-copy copy) +(define string-append string) +(define string-length string.count) +(define string->symbol symbol) +(define (symbol->string s) (string s)) + +(define (string-ref s i) + (string.char s (string.inc s 0 i))) diff --git a/femtolisp/ast/asttools.lsp b/femtolisp/ast/asttools.lsp index 968f85a..4b8e622 100644 --- a/femtolisp/ast/asttools.lsp +++ b/femtolisp/ast/asttools.lsp @@ -2,7 +2,7 @@ ; utilities for AST processing (define (symconcat s1 s2) - (intern (string s1 s2))) + (symbol (string s1 s2))) (define (list-adjoin item lst) (if (member item lst) diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp index 9911066..6adba31 100644 --- a/femtolisp/ast/rpasses.lsp +++ b/femtolisp/ast/rpasses.lsp @@ -21,7 +21,7 @@ (let ((ctr 0)) (set! r-gensym (lambda () - (prog1 (intern (string "%r:" ctr)) + (prog1 (symbol (string "%r:" ctr)) (set! ctr (+ ctr 1)))))) (define (dollarsign-transform e) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 340c7fe..f0c267c 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -130,11 +130,11 @@ static value_t fl_exit(value_t *args, u_int32_t nargs) return NIL; } -static value_t fl_intern(value_t *args, u_int32_t nargs) +static value_t fl_symbol(value_t *args, u_int32_t nargs) { - argcount("intern", nargs, 1); + argcount("symbol", nargs, 1); if (!isstring(args[0])) - type_error("intern", "string", args[0]); + type_error("symbol", "string", args[0]); return symbol(cvalue_data(args[0])); } @@ -416,7 +416,7 @@ static builtinspec_t builtin_info[] = { { "set-top-level-value!", fl_set_top_level_value }, { "raise", fl_raise }, { "exit", fl_exit }, - { "intern", fl_intern }, + { "symbol", fl_symbol }, { "fixnum", fl_fixnum }, { "truncate", fl_truncate }, diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index baa6bad..eaee32d 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -17,7 +17,7 @@ (k (apply f args)))) (define *funcall/cc-names* (list->vector - (map (lambda (i) (intern (string 'funcall/cc- i))) + (map (lambda (i) (symbol (string 'funcall/cc- i))) (iota 6)))) (define-macro (def-funcall/cc-n args) (let ((name (aref *funcall/cc-names* (length args)))) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 2028909..e029004 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -1,35 +1,29 @@ /* femtoLisp - a minimal interpreter for a minimal lisp dialect + a compact interpreter for a minimal lisp/scheme dialect - this lisp dialect uses lexical scope and self-evaluating lambda. - it supports 30-bit integers, symbols, conses, and full macros. - it is case-sensitive. - it features a simple compacting copying garbage collector. - it uses a Scheme-style evaluation rule where any expression may appear in - head position as long as it evaluates to a function. - it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (begin ...) for multiple - expressions. this is due to the closure representation - (lambda args body . env) + characteristics: + * lexical scope, lisp-1 + * unrestricted macros + * data types: 30-bit integer, symbol, pair, vector, char, string, table + iostream, procedure, low-level data types + * case-sensitive + * simple compacting copying garbage collector + * Scheme-style varargs (dotted formal argument lists) + * "human-readable" bytecode with self-hosted compiler - This is a fully fleshed-out lisp built up from femtoLisp. It has all the - remaining features needed to be taken seriously: + extra features: * circular structure can be printed and read - * #. read macro for eval-when-read and correctly printing builtins + * #. read macro for eval-when-read and readably printing builtins * read macros for backquote * symbol character-escaping printer - * vectors * exceptions * gensyms (can be usefully read back in, too) - * #| multiline comments |# + * #| multiline comments |#, lots of other lexical syntax * generic compare function, cyclic equal * cvalues system providing C data types and a C FFI * constructor notation for nicely printing arbitrary values - * strings - * hash tables - * I/O streams by Jeff Bezanson (C) 2009 Distributed under the BSD License @@ -738,61 +732,6 @@ static value_t apply_liststar(value_t L, int star) return POP(); } -value_t fl_copylist(value_t *args, u_int32_t nargs) -{ - argcount("copy-list", nargs, 1); - return FL_COPYLIST(args[0]); -} - -value_t fl_append(value_t *args, u_int32_t nargs) -{ - if (nargs == 0) - return NIL; - value_t first=NIL, lst, lastcons=NIL; - fl_gc_handle(&first); - fl_gc_handle(&lastcons); - uint32_t i=0; - while (1) { - if (i >= MAX_ARGS) { - lst = car_(args[MAX_ARGS]); - args[MAX_ARGS] = cdr_(args[MAX_ARGS]); - if (!iscons(args[MAX_ARGS])) break; - } - else { - lst = args[i++]; - if (i >= nargs) break; - } - if (iscons(lst)) { - lst = FL_COPYLIST(lst); - if (first == NIL) - first = lst; - else - cdr_(lastcons) = lst; - lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS); - } - else if (lst != NIL) { - type_error("append", "cons", lst); - } - } - if (first == NIL) - first = lst; - else - cdr_(lastcons) = lst; - fl_free_gc_handles(2); - return first; -} - -value_t fl_liststar(value_t *args, u_int32_t nargs) -{ - if (nargs == 1) return args[0]; - else if (nargs == 0) argcount("list*", nargs, 1); - if (nargs > MAX_ARGS) { - args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1); - return list(args, nargs); - } - return _list(args, nargs, 1); -} - static value_t do_trycatch() { uint32_t saveSP = SP; @@ -1717,12 +1656,7 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len) return maxsp+6; } -// initialization ------------------------------------------------------------- - -extern void builtins_init(); -extern void comparehash_init(); - -static char *EXEDIR = NULL; +// builtins ------------------------------------------------------------------- void assign_global_builtins(builtinspec_t *b) { @@ -1784,6 +1718,61 @@ static value_t fl_function_env(value_t *args, uint32_t nargs) return fn_env(v); } +value_t fl_copylist(value_t *args, u_int32_t nargs) +{ + argcount("copy-list", nargs, 1); + return FL_COPYLIST(args[0]); +} + +value_t fl_append(value_t *args, u_int32_t nargs) +{ + if (nargs == 0) + return NIL; + value_t first=NIL, lst, lastcons=NIL; + fl_gc_handle(&first); + fl_gc_handle(&lastcons); + uint32_t i=0; + while (1) { + if (i >= MAX_ARGS) { + lst = car_(args[MAX_ARGS]); + args[MAX_ARGS] = cdr_(args[MAX_ARGS]); + if (!iscons(args[MAX_ARGS])) break; + } + else { + lst = args[i++]; + if (i >= nargs) break; + } + if (iscons(lst)) { + lst = FL_COPYLIST(lst); + if (first == NIL) + first = lst; + else + cdr_(lastcons) = lst; + lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS); + } + else if (lst != NIL) { + type_error("append", "cons", lst); + } + } + if (first == NIL) + first = lst; + else + cdr_(lastcons) = lst; + fl_free_gc_handles(2); + return first; +} + +value_t fl_liststar(value_t *args, u_int32_t nargs) +{ + if (nargs == 1) return args[0]; + else if (nargs == 0) argcount("list*", nargs, 1); + if (nargs > MAX_ARGS) { + args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1); + return list(args, nargs); + } + return _list(args, nargs, 1); +} + static builtinspec_t core_builtin_info[] = { { "function", fl_function }, { "function:code", fl_function_code }, @@ -1797,6 +1786,13 @@ static builtinspec_t core_builtin_info[] = { { NULL, NULL } }; +// initialization ------------------------------------------------------------- + +extern void builtins_init(); +extern void comparehash_init(); + +static char *EXEDIR = NULL; + static void lisp_init(void) { int i; @@ -1870,6 +1866,9 @@ static void lisp_init(void) setc(symbol("*os-name*"), symbol("unknown")); #endif + the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR); + vector_setsize(the_empty_vector, 0); + cvalues_init(); char buf[1024]; @@ -1883,9 +1882,6 @@ static void lisp_init(void) memory_exception_value = list2(MemoryError, cvalue_static_cstring("out of memory")); - the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR); - vector_setsize(the_empty_vector, 0); - assign_global_builtins(core_builtin_info); builtins_init();