ref: a9b0f7879bd5e35212902e7b783c4be659f608f3
parent: 8f93c9dfc67de6759f713809d7faa37c5cb7a30c
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Mon Mar 23 16:44:19 EDT 2009
removing some unnecessary stuff improving key-error
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -94,17 +94,6 @@
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 @@
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);
+ global_env_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);
- 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 @@
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 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 },
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1522,6 +1522,8 @@
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"));
--- 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)
--- 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.
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -119,6 +119,11 @@
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 @@
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 @@
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];
}