diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 0a53615..8601ee2 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -26,7 +26,59 @@ size_t llength(value_t v) return n; } -value_t fl_exit(value_t *args, u_int32_t nargs) +static value_t fl_nconc(value_t *args, u_int32_t nargs) +{ + if (nargs == 0) + return NIL; + value_t first=NIL; + value_t *pcdr = &first; + cons_t *c; + int a; + for(a=0; a < (int)nargs-1; a++) { + if (iscons(args[a])) { + *pcdr = args[a]; + c = (cons_t*)ptr(args[a]); + while (iscons(c->cdr)) + c = (cons_t*)ptr(c->cdr); + pcdr = &c->cdr; + } + else if (args[a] != NIL) { + type_error("nconc", "cons", args[a]); + } + } + *pcdr = args[a]; + return first; +} + +static value_t fl_assq(value_t *args, u_int32_t nargs) +{ + argcount("assq", nargs, 2); + value_t item = args[0]; + value_t v = args[1]; + value_t bind; + + while (iscons(v)) { + bind = car_(v); + if (iscons(bind) && car_(bind) == item) + return bind; + v = cdr_(v); + } + return FL_F; +} + +static value_t fl_memq(value_t *args, u_int32_t nargs) +{ + argcount("memq", nargs, 2); + while (iscons(args[1])) { + cons_t *c = (cons_t*)ptr(args[1]); + if (c->car == args[0]) + return args[1]; + args[1] = c->cdr; + } + return FL_F; +} + +static value_t fl_exit(value_t *args, u_int32_t nargs) { if (nargs > 0) exit(tofixnum(args[0], "exit")); @@ -34,7 +86,7 @@ value_t fl_exit(value_t *args, u_int32_t nargs) return NIL; } -value_t fl_intern(value_t *args, u_int32_t nargs) +static value_t fl_intern(value_t *args, u_int32_t nargs) { argcount("intern", nargs, 1); if (!isstring(args[0])) @@ -42,7 +94,7 @@ value_t fl_intern(value_t *args, u_int32_t nargs) return symbol(cvalue_data(args[0])); } -value_t fl_setconstant(value_t *args, u_int32_t nargs) +static value_t fl_setconstant(value_t *args, u_int32_t nargs) { argcount("set-constant!", nargs, 2); symbol_t *sym = tosymbol(args[0], "set-constant!"); @@ -55,7 +107,7 @@ value_t fl_setconstant(value_t *args, u_int32_t nargs) extern value_t LAMBDA; -value_t fl_setsyntax(value_t *args, u_int32_t nargs) +static value_t fl_setsyntax(value_t *args, u_int32_t nargs) { argcount("set-syntax!", nargs, 2); symbol_t *sym = tosymbol(args[0], "set-syntax!"); @@ -73,7 +125,7 @@ value_t fl_setsyntax(value_t *args, u_int32_t nargs) return args[1]; } -value_t fl_symbolsyntax(value_t *args, u_int32_t nargs) +static value_t fl_symbolsyntax(value_t *args, u_int32_t nargs) { argcount("symbol-syntax", nargs, 1); symbol_t *sym = tosymbol(args[0], "symbol-syntax"); @@ -111,7 +163,7 @@ static void global_env_assoc_list(symbol_t *root, value_t *pv) extern symbol_t *symtab; -value_t fl_syntax_env(value_t *args, u_int32_t nargs) +static value_t fl_syntax_env(value_t *args, u_int32_t nargs) { (void)args; argcount("syntax-environment", nargs, 0); @@ -130,7 +182,7 @@ value_t fl_global_env(value_t *args, u_int32_t nargs) extern value_t QUOTE; -value_t fl_constantp(value_t *args, u_int32_t nargs) +static value_t fl_constantp(value_t *args, u_int32_t nargs) { argcount("constant?", nargs, 1); if (issymbol(args[0])) @@ -143,7 +195,7 @@ value_t fl_constantp(value_t *args, u_int32_t nargs) return FL_T; } -value_t fl_integerp(value_t *args, u_int32_t nargs) +static value_t fl_integerp(value_t *args, u_int32_t nargs) { argcount("integer?", nargs, 1); value_t v = args[0]; @@ -172,7 +224,7 @@ value_t fl_integerp(value_t *args, u_int32_t nargs) return FL_F; } -value_t fl_fixnum(value_t *args, u_int32_t nargs) +static value_t fl_fixnum(value_t *args, u_int32_t nargs) { argcount("fixnum", nargs, 1); if (isfixnum(args[0])) { @@ -194,7 +246,7 @@ value_t fl_fixnum(value_t *args, u_int32_t nargs) lerror(ArgError, "fixnum: cannot convert argument"); } -value_t fl_truncate(value_t *args, u_int32_t nargs) +static value_t fl_truncate(value_t *args, u_int32_t nargs) { argcount("truncate", nargs, 1); if (isfixnum(args[0])) @@ -217,7 +269,7 @@ value_t fl_truncate(value_t *args, u_int32_t nargs) type_error("truncate", "number", args[0]); } -value_t fl_vector_alloc(value_t *args, u_int32_t nargs) +static value_t fl_vector_alloc(value_t *args, u_int32_t nargs) { fixnum_t i; value_t f, v; @@ -239,7 +291,7 @@ value_t fl_vector_alloc(value_t *args, u_int32_t nargs) return v; } -value_t fl_time_now(value_t *args, u_int32_t nargs) +static value_t fl_time_now(value_t *args, u_int32_t nargs) { argcount("time.now", nargs, 0); (void)args; @@ -258,7 +310,7 @@ static double todouble(value_t a, char *fname) type_error(fname, "number", a); } -value_t fl_time_string(value_t *args, uint32_t nargs) +static value_t fl_time_string(value_t *args, uint32_t nargs) { argcount("time.string", nargs, 1); double t = todouble(args[0], "time.string"); @@ -267,7 +319,7 @@ value_t fl_time_string(value_t *args, uint32_t nargs) return string_from_cstr(buf); } -value_t fl_path_cwd(value_t *args, uint32_t nargs) +static value_t fl_path_cwd(value_t *args, uint32_t nargs) { if (nargs > 1) argcount("path.cwd", nargs, 1); @@ -282,7 +334,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs) return FL_T; } -value_t fl_os_getenv(value_t *args, uint32_t nargs) +static value_t fl_os_getenv(value_t *args, uint32_t nargs) { argcount("os.getenv", nargs, 1); char *name = tostring(args[0], "os.getenv"); @@ -293,7 +345,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs) return cvalue_static_cstring(val); } -value_t fl_os_setenv(value_t *args, uint32_t nargs) +static value_t fl_os_setenv(value_t *args, uint32_t nargs) { argcount("os.setenv", nargs, 2); char *name = tostring(args[0], "os.setenv"); @@ -310,7 +362,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs) return FL_T; } -value_t fl_rand(value_t *args, u_int32_t nargs) +static value_t fl_rand(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; fixnum_t r; @@ -321,7 +373,7 @@ value_t fl_rand(value_t *args, u_int32_t nargs) #endif return fixnum(r); } -value_t fl_rand32(value_t *args, u_int32_t nargs) +static value_t fl_rand32(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; ulong r = random(); @@ -331,18 +383,18 @@ value_t fl_rand32(value_t *args, u_int32_t nargs) return mk_uint32(r); #endif } -value_t fl_rand64(value_t *args, u_int32_t nargs) +static value_t fl_rand64(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; uint64_t r = (((uint64_t)random())<<32) | random(); return mk_uint64(r); } -value_t fl_randd(value_t *args, u_int32_t nargs) +static value_t fl_randd(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; return mk_double(rand_double()); } -value_t fl_randf(value_t *args, u_int32_t nargs) +static value_t fl_randf(value_t *args, u_int32_t nargs) { (void)args; (void)nargs; return mk_float(rand_float()); @@ -365,6 +417,9 @@ static builtinspec_t builtin_info[] = { { "fixnum", fl_fixnum }, { "truncate", fl_truncate }, { "integer?", fl_integerp }, + { "nconc", fl_nconc }, + { "assq", fl_assq }, + { "memq", fl_memq }, { "vector.alloc", fl_vector_alloc }, diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 0ade7d4..7f41f92 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -275,7 +275,7 @@ num_init(uint64, uint64, T_UINT64) num_init(float, double, T_FLOAT) num_init(double, double, T_DOUBLE) -#define num_ctor(typenam, ctype, tag) \ +#define num_ctor_init(typenam, ctype, tag) \ value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \ { \ if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \ @@ -284,7 +284,9 @@ value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \ args[0], cp_data((cprim_t*)ptr(cp)))) \ type_error(#typenam, "number", args[0]); \ return cp; \ -} \ +} + +#define num_ctor_ctor(typenam, ctype, tag) \ value_t mk_##typenam(ctype##_t n) \ { \ value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \ @@ -292,6 +294,10 @@ value_t mk_##typenam(ctype##_t n) \ return cp; \ } +#define num_ctor(typenam, ctype, tag) \ + num_ctor_init(typenam, ctype, tag) \ + num_ctor_ctor(typenam, ctype, tag) + num_ctor(int8, int8, T_INT8) num_ctor(uint8, uint8, T_UINT8) num_ctor(int16, int16, T_INT16) @@ -823,8 +829,20 @@ static value_t cvalue_array_aref(value_t *args) { char *data; ulong_t index; fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype; - value_t el = cvalue(eltype, eltype->size); + value_t el; + numerictype_t nt = eltype->numtype; + if (nt >= T_INT32) + el = cvalue(eltype, eltype->size); check_addr_args("aref", args[0], args[1], &data, &index); + if (nt < T_INT32) { + if (nt == T_INT8) + return fixnum((int8_t)data[index]); + else if (nt == T_UINT8) + return fixnum((uint8_t)data[index]); + else if (nt == T_INT16) + return fixnum(((int16_t*)data)[index]); + return fixnum(((uint16_t*)data)[index]); + } char *dest = cptr(el); size_t sz = eltype->size; if (sz == 1) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index d7a6283..ca994e1 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -71,7 +71,7 @@ static char *builtin_names[] = "compare", // sequences - "vector", "aref", "aset!", "length", "assq", "for", + "vector", "aref", "aset!", "length", "for", "", "", "" }; #define N_STACK 98304 @@ -608,20 +608,6 @@ int isnumber(value_t v) // eval ----------------------------------------------------------------------- -// return a cons element of v whose car is item -static value_t assq(value_t item, value_t v) -{ - value_t bind; - - while (iscons(v)) { - bind = car_(v); - if (iscons(bind) && car_(bind) == item) - return bind; - v = cdr_(v); - } - return FL_F; -} - /* take the final cdr as an argument so the list builtin can give the same result as (lambda x x). @@ -1299,10 +1285,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) lerror(ArgError, "prog1: too few arguments"); v = Stack[saveSP+1]; break; - case F_ASSQ: - argcount("assq", nargs, 2); - v = assq(Stack[SP-2], Stack[SP-1]); - break; case F_FOR: argcount("for", nargs, 3); lo = tofixnum(Stack[SP-3], "for"); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 6ef34ed..b04fa0d 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -112,7 +112,7 @@ enum { F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH, F_COMPARE, - F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR, + F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR, F_TRUE, F_FALSE, F_NIL, N_BUILTINS, }; diff --git a/femtolisp/string.c b/femtolisp/string.c index 528bb41..7f2edd1 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -264,7 +264,7 @@ value_t fl_string_inc(value_t *args, u_int32_t nargs) while (cnt--) { if (i >= len) bounds_error("string.inc", args[0], args[1]); - u8_inc(s, &i); + (void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i); } return size_wrap(i); } @@ -285,7 +285,7 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs) while (cnt--) { if (i == 0) bounds_error("string.dec", args[0], args[1]); - u8_dec(s, &i); + (void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i); } return size_wrap(i); } diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 66d3519..d22cb4b 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -60,14 +60,6 @@ (map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))) #f)) -(define (nconc . lsts) - (cond ((null? lsts) ()) - ((null? (cdr lsts)) (car lsts)) - ((null? (car lsts)) (apply nconc (cdr lsts))) - (#t (prog1 (car lsts) - (set-cdr! (last (car lsts)) - (apply nconc (cdr lsts))))))) - (define (append . lsts) (cond ((null? lsts) ()) ((null? (cdr lsts)) (car lsts)) @@ -81,10 +73,6 @@ (cond ((atom? lst) #f) ((equal? (car lst) item) lst) (#t (member item (cdr lst))))) -(define (memq item lst) - (cond ((atom? lst) #f) - ((eq? (car lst) item) lst) - (#t (memq item (cdr lst))))) (define (memv item lst) (cond ((atom? lst) #f) ((eqv? (car lst) item) lst) @@ -121,9 +109,6 @@ (define (cadr x) (car (cdr x))) -;(set! *special-forms* '(quote cond if and or while lambda trycatch -; set! begin)) - (define (macroexpand e) ((label mexpand (lambda (e env f) @@ -574,27 +559,27 @@ (define (string.trim s at-start at-end) (define (trim-start s chars i L) - (if (and (< i L) - (string.find chars (string.char s i))) - (trim-start s chars (string.inc s i) L) + (if (and (#.< i L) + (#.string.find chars (#.string.char s i))) + (trim-start s chars (#.string.inc s i) L) i)) (define (trim-end s chars i) (if (and (> i 0) - (string.find chars (string.char s (string.dec s i)))) - (trim-end s chars (string.dec s i)) + (#.string.find chars (#.string.char s (#.string.dec s i)))) + (trim-end s chars (#.string.dec s i)) i)) - (let ((L (length s))) + (let ((L (#.length s))) (string.sub s (trim-start s at-start 0 L) (trim-end s at-end L)))) (define (string.map f s) (let ((b (buffer)) - (n (length s))) + (n (#.length s))) (let ((i 0)) - (while (< i n) - (begin (io.putc b (f (string.char s i))) - (set! i (string.inc s i))))) + (while (#.< i n) + (begin (#.io.putc b (f (#.string.char s i))) + (set! i (#.string.inc s i))))) (io.tostring! b))) (define (print-to-string v) diff --git a/femtolisp/todo b/femtolisp/todo index a3b3737..e0fd0cc 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -137,6 +137,8 @@ for internal use: instead, unless the value is part of an aggregate (e.g. struct). . this avoids allocating a new type for every size. . and/or add function array.alloc +x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?) + . this made no difference in a string.map microbenchmark bugs: * with the fully recursive (simpler) relocate(), the size of cons chains @@ -957,8 +959,6 @@ consolidated todo list as of 8/30: - eliminate string copy in lerror() when possible * fix printing lists of short strings -- preallocate all byte,int8,uint8 values, and some wchars - - remaining c types - remaining cvalues functions - finish ios