shithub: femtolisp

Info  •  Files  •  Log

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];

 }