removing some unnecessary stuff

improving key-error
This commit is contained in:
JeffBezanson 2009-03-23 20:44:19 +00:00
parent 8f93c9dfc6
commit a9b0f7879b
5 changed files with 23 additions and 56 deletions

View File

@ -94,17 +94,6 @@ static value_t fl_intern(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0])); 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; extern value_t LAMBDA;
static value_t fl_setsyntax(value_t *args, u_int32_t nargs) 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; 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) { while (root != NULL) {
if (root->syntax && root->syntax != TAG_CONST && if (root->name[0] != ':' &&
!isspecial(root->syntax)) { (root->binding != UNBOUND ||
PUSH(fl_cons(tagptr(root,TAG_SYM), root->syntax)); (root->syntax && root->syntax != TAG_CONST &&
*pv = fl_cons(POP(), *pv); !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; root = root->right;
} }
} }
extern symbol_t *symtab; 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) value_t fl_global_env(value_t *args, u_int32_t nargs)
{ {
(void)args; (void)args;
argcount("environment", nargs, 0); argcount("environment", nargs, 0);
PUSH(NIL); PUSH(NIL);
global_env_assoc_list(symtab, &Stack[SP-1]); global_env_list(symtab, &Stack[SP-1]);
return POP(); 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]); cprim_t *cp = (cprim_t*)ptr(args[0]);
return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp))); return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
} }
else if (isstring(args[0])) { type_error("fixnum", "number", 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");
} }
static value_t fl_truncate(value_t *args, u_int32_t nargs) static value_t fl_truncate(value_t *args, u_int32_t nargs)
@ -405,10 +367,8 @@ extern void table_init();
extern void iostream_init(); extern void iostream_init();
static builtinspec_t builtin_info[] = { static builtinspec_t builtin_info[] = {
{ "set-constant!", fl_setconstant },
{ "set-syntax!", fl_setsyntax }, { "set-syntax!", fl_setsyntax },
{ "symbol-syntax", fl_symbolsyntax }, { "symbol-syntax", fl_symbolsyntax },
{ "syntax-environment", fl_syntax_env },
{ "environment", fl_global_env }, { "environment", fl_global_env },
{ "constant?", fl_constantp }, { "constant?", fl_constantp },

View File

@ -1522,6 +1522,8 @@ static void lisp_init(void)
for (; i < F_TRUE; i++) { for (; i < F_TRUE; i++) {
setc(symbol(builtin_names[i]), builtin(i)); setc(symbol(builtin_names[i]), builtin(i));
} }
setc(symbol("eq"), builtin(F_EQ));
setc(symbol("equal"), builtin(F_EQUAL));
#ifdef LINUX #ifdef LINUX
set(symbol("*os-name*"), symbol("linux")); set(symbol("*os-name*"), symbol("linux"));

View File

@ -1,6 +1,11 @@
macroexpand macroexpand
append append
bq-process bq-process
(define (syntax-environment)
(map (lambda (s) (cons s (symbol-syntax s)))
(filter symbol-syntax (environment))))
(syntax-environment) (syntax-environment)
(symbol-syntax 'try) (symbol-syntax 'try)

View File

@ -3,11 +3,6 @@
; by Jeff Bezanson (C) 2009 ; by Jeff Bezanson (C) 2009
; Distributed under the BSD License ; 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. ; convert a sequence of body statements to a single expression.
; this allows define, defun, defmacro, let, etc. to contain multiple ; this allows define, defun, defmacro, let, etc. to contain multiple
; body expressions as in Common Lisp. ; body expressions as in Common Lisp.

View File

@ -119,6 +119,11 @@ value_t fl_table_put(value_t *args, uint32_t nargs)
return args[0]; 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]) // (get table key [default])
value_t fl_table_get(value_t *args, uint32_t nargs) 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 (v == (value_t)HT_NOTFOUND) {
if (nargs == 3) if (nargs == 3)
return args[2]; return args[2];
lerror(KeyError, "get: key not found"); key_error("get", args[1]);
} }
return v; return v;
} }
@ -148,7 +153,7 @@ value_t fl_table_del(value_t *args, uint32_t nargs)
argcount("del!", nargs, 2); argcount("del!", nargs, 2);
htable_t *h = totable(args[0], "del!"); htable_t *h = totable(args[0], "del!");
if (!equalhash_remove(h, (void*)args[1])) if (!equalhash_remove(h, (void*)args[1]))
lerror(KeyError, "del!: key not found"); key_error("del!", args[1]);
return args[0]; return args[0];
} }