diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 8601ee2..d8f3b14 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -94,17 +94,6 @@ static value_t fl_intern(value_t *args, u_int32_t nargs) return symbol(cvalue_data(args[0])); } -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!"); - if (isconstant(args[0]) || sym->binding != UNBOUND) - lerror(ArgError, "set-constant!: cannot redefine %s", - symbol_name(args[0])); - setc(args[0], args[1]); - return args[1]; -} - extern value_t LAMBDA; static value_t fl_setsyntax(value_t *args, u_int32_t nargs) @@ -137,46 +126,28 @@ static value_t fl_symbolsyntax(value_t *args, u_int32_t nargs) return sym->syntax; } -static void syntax_env_assoc_list(symbol_t *root, value_t *pv) +static void global_env_list(symbol_t *root, value_t *pv) { while (root != NULL) { - if (root->syntax && root->syntax != TAG_CONST && - !isspecial(root->syntax)) { - PUSH(fl_cons(tagptr(root,TAG_SYM), root->syntax)); - *pv = fl_cons(POP(), *pv); + if (root->name[0] != ':' && + (root->binding != UNBOUND || + (root->syntax && root->syntax != TAG_CONST && + !isspecial(root->syntax)))) { + *pv = fl_cons(tagptr(root,TAG_SYM), *pv); } - syntax_env_assoc_list(root->left, pv); - root = root->right; - } -} -static void global_env_assoc_list(symbol_t *root, value_t *pv) -{ - while (root != NULL) { - if (root->binding != UNBOUND) { - PUSH(fl_cons(tagptr(root,TAG_SYM), root->binding)); - *pv = fl_cons(POP(), *pv); - } - global_env_assoc_list(root->left, pv); + global_env_list(root->left, pv); root = root->right; } } extern symbol_t *symtab; -static value_t fl_syntax_env(value_t *args, u_int32_t nargs) -{ - (void)args; - argcount("syntax-environment", nargs, 0); - PUSH(NIL); - syntax_env_assoc_list(symtab, &Stack[SP-1]); - return POP(); -} value_t fl_global_env(value_t *args, u_int32_t nargs) { (void)args; argcount("environment", nargs, 0); PUSH(NIL); - global_env_assoc_list(symtab, &Stack[SP-1]); + global_env_list(symtab, &Stack[SP-1]); return POP(); } @@ -234,16 +205,7 @@ static value_t fl_fixnum(value_t *args, u_int32_t nargs) cprim_t *cp = (cprim_t*)ptr(args[0]); return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp))); } - else if (isstring(args[0])) { - cvalue_t *cv = (cvalue_t*)ptr(args[0]); - char *pend; - errno = 0; - long i = strtol(cv_data(cv), &pend, 0); - if (*pend != '\0' || errno!=0) - lerror(ArgError, "fixnum: invalid string"); - return fixnum(i); - } - lerror(ArgError, "fixnum: cannot convert argument"); + type_error("fixnum", "number", args[0]); } static value_t fl_truncate(value_t *args, u_int32_t nargs) @@ -405,10 +367,8 @@ extern void table_init(); extern void iostream_init(); static builtinspec_t builtin_info[] = { - { "set-constant!", fl_setconstant }, { "set-syntax!", fl_setsyntax }, { "symbol-syntax", fl_symbolsyntax }, - { "syntax-environment", fl_syntax_env }, { "environment", fl_global_env }, { "constant?", fl_constantp }, diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 6f9c9a0..ee64958 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -1522,6 +1522,8 @@ static void lisp_init(void) for (; i < F_TRUE; i++) { setc(symbol(builtin_names[i]), builtin(i)); } + setc(symbol("eq"), builtin(F_EQ)); + setc(symbol("equal"), builtin(F_EQUAL)); #ifdef LINUX set(symbol("*os-name*"), symbol("linux")); diff --git a/femtolisp/printcases.lsp b/femtolisp/printcases.lsp index 702e11f..a94222f 100644 --- a/femtolisp/printcases.lsp +++ b/femtolisp/printcases.lsp @@ -1,6 +1,11 @@ macroexpand append bq-process + +(define (syntax-environment) + (map (lambda (s) (cons s (symbol-syntax s))) + (filter symbol-syntax (environment)))) + (syntax-environment) (symbol-syntax 'try) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 31d6f4d..2d544eb 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -3,11 +3,6 @@ ; by Jeff Bezanson (C) 2009 ; Distributed under the BSD License -(if (not (bound? 'eq)) - (begin - (set-constant! 'eq eq?) - (set-constant! 'equal equal?))) - ; convert a sequence of body statements to a single expression. ; this allows define, defun, defmacro, let, etc. to contain multiple ; body expressions as in Common Lisp. diff --git a/femtolisp/table.c b/femtolisp/table.c index ca4a5e7..a0085c2 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -119,6 +119,11 @@ value_t fl_table_put(value_t *args, uint32_t nargs) return args[0]; } +static void key_error(char *fname, value_t key) +{ + lerror(list2(KeyError, key), "%s: key not found", fname); +} + // (get table key [default]) value_t fl_table_get(value_t *args, uint32_t nargs) { @@ -129,7 +134,7 @@ value_t fl_table_get(value_t *args, uint32_t nargs) if (v == (value_t)HT_NOTFOUND) { if (nargs == 3) return args[2]; - lerror(KeyError, "get: key not found"); + key_error("get", args[1]); } return v; } @@ -148,7 +153,7 @@ value_t fl_table_del(value_t *args, uint32_t nargs) argcount("del!", nargs, 2); htable_t *h = totable(args[0], "del!"); if (!equalhash_remove(h, (void*)args[1])) - lerror(KeyError, "del!: key not found"); + key_error("del!", args[1]); return args[0]; }