diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index d8f3b14..e0d7fdb 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -78,6 +78,12 @@ static value_t fl_memq(value_t *args, u_int32_t nargs) return FL_F; } +static value_t fl_raise(value_t *args, u_int32_t nargs) +{ + argcount("raise", nargs, 1); + raise(args[0]); +} + static value_t fl_exit(value_t *args, u_int32_t nargs) { if (nargs > 0) @@ -101,8 +107,8 @@ 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!"); if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax))) - lerror(ArgError, "set-syntax!: cannot define syntax for %s", - symbol_name(args[0])); + lerrorf(ArgError, "set-syntax!: cannot define syntax for %s", + symbol_name(args[0])); if (args[1] == FL_F) { sym->syntax = 0; } @@ -292,7 +298,7 @@ static value_t fl_path_cwd(value_t *args, uint32_t nargs) } char *ptr = tostring(args[0], "path.cwd"); if (set_cwd(ptr)) - lerror(IOError, "path.cwd: could not cd to %s", ptr); + lerrorf(IOError, "path.cwd: could not cd to %s", ptr); return FL_T; } @@ -371,6 +377,7 @@ static builtinspec_t builtin_info[] = { { "symbol-syntax", fl_symbolsyntax }, { "environment", fl_global_env }, { "constant?", fl_constantp }, + { "raise", fl_raise }, { "exit", fl_exit }, { "intern", fl_intern }, diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 867ab23..1d39898 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -1,4 +1,9 @@ ; -*- scheme -*- +(define (cond-body e) + (cond ((atom? e) #f) + ((null? (cdr e)) (car e)) + (#t (cons 'begin e)))) + (define (cond->if form) (cond-clauses->if (cdr form))) (define (cond-clauses->if lst) @@ -6,7 +11,7 @@ lst (let ((clause (car lst))) `(if ,(car clause) - ,(f-body (cdr clause)) + ,(cond-body (cdr clause)) ,(cond-clauses->if (cdr lst)))))) (define (begin->cps forms k) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 7f41f92..a8f2cc3 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -200,9 +200,9 @@ value_t cvalue_string(size_t sz) return cvalue(stringtype, sz); } -value_t cvalue_static_cstring(char *str) +value_t cvalue_static_cstring(const char *str) { - return cvalue_from_ref(stringtype, str, strlen(str), NIL); + return cvalue_from_ref(stringtype, (char*)str, strlen(str), NIL); } value_t string_from_cstrn(char *str, size_t n) @@ -899,12 +899,21 @@ value_t cbuiltin(char *name, builtin_t f) */ } +static value_t fl_logand(value_t *args, u_int32_t nargs); +static value_t fl_logior(value_t *args, u_int32_t nargs); +static value_t fl_logxor(value_t *args, u_int32_t nargs); +static value_t fl_ash(value_t *args, u_int32_t nargs); + static builtinspec_t cvalues_builtin_info[] = { { "c-value", cvalue_new }, { "typeof", cvalue_typeof }, { "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy }, + { "logand", fl_logand }, + { "logior", fl_logior }, + { "logxor", fl_logxor }, + { "ash", fl_ash }, // todo: autorelease { NULL, NULL } }; @@ -1321,40 +1330,6 @@ static value_t fl_bitwise_not(value_t a) return NIL; } -static value_t fl_ash(value_t a, int n) -{ - cprim_t *cp; - int ta; - void *aptr; - if (iscprim(a)) { - if (n == 0) return a; - cp = (cprim_t*)ptr(a); - ta = cp_numtype(cp); - aptr = cp_data(cp); - if (n < 0) { - n = -n; - switch (ta) { - case T_INT8: return fixnum((*(int8_t *)aptr) >> n); - case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n); - case T_INT16: return fixnum((*(int16_t *)aptr) >> n); - case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n); - case T_INT32: return mk_int32((*(int32_t *)aptr) >> n); - case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n); - case T_INT64: return mk_int64((*(int64_t *)aptr) >> n); - case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n); - } - } - else { - if (ta == T_UINT64) - return return_from_uint64((*(uint64_t*)aptr)<>(-n)); + accum = ((int64_t)numval(a))<> n); + case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n); + case T_INT16: return fixnum((*(int16_t *)aptr) >> n); + case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n); + case T_INT32: return mk_int32((*(int32_t *)aptr) >> n); + case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n); + case T_INT64: return mk_int64((*(int64_t *)aptr) >> n); + case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n); + } + } + else { + if (ta == T_UINT64) + return return_from_uint64((*(uint64_t*)aptr)< 1) { - e = Stack[SP-nargs+1]; - if (bothfixnums(v, e)) - v = v & e; - else - v = fl_bitwise_op(v, e, 0, "&"); - nargs--; - Stack[SP-nargs] = v; - } - } - break; - case F_BOR: - if (nargs == 0) - v = fixnum(0); - else { - v = Stack[SP-nargs]; - while (nargs > 1) { - e = Stack[SP-nargs+1]; - if (bothfixnums(v, e)) - v = v | e; - else - v = fl_bitwise_op(v, e, 1, "!"); - nargs--; - Stack[SP-nargs] = v; - } - } - break; - case F_BXOR: - if (nargs == 0) - v = fixnum(0); - else { - v = Stack[SP-nargs]; - while (nargs > 1) { - e = Stack[SP-nargs+1]; - if (bothfixnums(v, e)) - v = fixnum(numval(v) ^ numval(e)); - else - v = fl_bitwise_op(v, e, 2, "$"); - nargs--; - Stack[SP-nargs] = v; - } - } - break; - case F_ASH: - argcount("ash", nargs, 2); - i = tofixnum(Stack[SP-1], "ash"); - if (isfixnum(Stack[SP-2])) { - if (i <= 0) - v = fixnum(numval(Stack[SP-2])>>(-i)); - else { - accum = ((int64_t)numval(Stack[SP-2]))< 0x7f, or anything else > 0xff, are out of range if ((iscprim(arg) && cp_class((cprim_t*)ptr(arg))==wchartype) || uldelim > 0xff) - lerror(ArgError, "%s: delimiter out of range", fname); + lerrorf(ArgError, "%s: delimiter out of range", fname); } return (char)uldelim; } diff --git a/femtolisp/read.c b/femtolisp/read.c index eb99f4e..62953ad 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -305,7 +305,7 @@ static u_int32_t peek() (isdigit_base(buf[1],base) || buf[1]=='-')) { if (!read_numtok(&buf[1], &tokval, base)) - lerror(ParseError, "read: invalid base %d constant", base); + lerrorf(ParseError, "read: invalid base %d constant", base); return (toktype=TOK_NUM); } @@ -546,8 +546,8 @@ static value_t do_read_sexpr(value_t label) c = nextchar(); if (c != '(') { take(); - lerror(ParseError, "read: expected argument list for %s", - symbol_name(tokval)); + lerrorf(ParseError, "read: expected argument list for %s", + symbol_name(tokval)); } PUSH(NIL); read_list(&Stack[SP-1], UNBOUND); @@ -568,7 +568,7 @@ static value_t do_read_sexpr(value_t label) case TOK_LABEL: // create backreference label if (ptrhash_has(&readstate->backrefs, (void*)tokval)) - lerror(ParseError, "read: label %ld redefined", numval(tokval)); + lerrorf(ParseError, "read: label %ld redefined", numval(tokval)); oldtokval = tokval; v = do_read_sexpr(tokval); ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v); @@ -577,7 +577,7 @@ static value_t do_read_sexpr(value_t label) // look up backreference v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval); if (v == (value_t)HT_NOTFOUND) - lerror(ParseError, "read: undefined label %ld", numval(tokval)); + lerrorf(ParseError, "read: undefined label %ld", numval(tokval)); return v; case TOK_GENSYM: pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval); diff --git a/femtolisp/string.c b/femtolisp/string.c index 1edbbe6..dec1807 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -312,7 +312,7 @@ static ulong get_radix_arg(value_t arg, char *fname) { ulong radix = toulong(arg, fname); if (radix < 2 || radix > 36) - lerror(ArgError, "%s: invalid radix", fname); + lerrorf(ArgError, "%s: invalid radix", fname); return radix; } diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 2d544eb..ce27027 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -184,8 +184,6 @@ (define (abs x) (if (< x 0) (- x) x)) (define (identity x) x) (define (char? x) (eq? (typeof x) 'wchar)) -(define K prog1) ; K combinator ;) -(define begin0 prog1) (define (caar x) (car (car x))) (define (cdar x) (cdr (car x))) diff --git a/femtolisp/table.c b/femtolisp/table.c index a0085c2..5394448 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -121,7 +121,7 @@ value_t fl_table_put(value_t *args, uint32_t nargs) static void key_error(char *fname, value_t key) { - lerror(list2(KeyError, key), "%s: key not found", fname); + lerrorf(list2(KeyError, key), "%s: key not found", fname); } // (get table key [default]) diff --git a/femtolisp/todo b/femtolisp/todo index e0fd0cc..2310e9c 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -962,6 +962,7 @@ consolidated todo list as of 8/30: - remaining c types - remaining cvalues functions - finish ios + - special efficient reader for #array - reimplement vectors as (array lispvalue) - implement fast subvectors and subarrays diff --git a/llt/int2str.c b/llt/int2str.c index 2210fde..f3abec3 100644 --- a/llt/int2str.c +++ b/llt/int2str.c @@ -31,6 +31,7 @@ int isdigit_base(char c, int base) } /* assumes valid base, returns 1 on error, 0 if OK */ +/* int str2int(char *str, size_t len, int64_t *res, uint32_t base) { int64_t result, place; @@ -54,3 +55,4 @@ int str2int(char *str, size_t len, int64_t *res, uint32_t base) *res = result; return 0; } +*/