making nconc, assq, and memq builtins

some small optimizations to string.map, string.trim,
string.inc, string.dec, aref

femtolisp/builtins.c

@@ -26,7 +26,59 @@ size_t llength(value_t v)
     return n;
 }
 
-value_t fl_exit(value_t *args, u_int32_t nargs)
+static value_t fl_nconc(value_t *args, u_int32_t nargs)
+{
+    if (nargs == 0)
+        return NIL;
+    value_t first=NIL;
+    value_t *pcdr = &first;
+    cons_t *c;
+    int a;
+    for(a=0; a < (int)nargs-1; a++) {
+        if (iscons(args[a])) {
+            *pcdr = args[a];
+            c = (cons_t*)ptr(args[a]);
+            while (iscons(c->cdr))
+                c = (cons_t*)ptr(c->cdr);
+            pcdr = &c->cdr;
+        }
+        else if (args[a] != NIL) {
+            type_error("nconc", "cons", args[a]);
+        }
+    }
+    *pcdr = args[a];
+    return first;
+}
+
+static value_t fl_assq(value_t *args, u_int32_t nargs)
+{
+    argcount("assq", nargs, 2);
+    value_t item = args[0];
+    value_t v = args[1];
+    value_t bind;
+
+    while (iscons(v)) {
+        bind = car_(v);
+        if (iscons(bind) && car_(bind) == item)
+            return bind;
+        v = cdr_(v);
+    }
+    return FL_F;
+}
+
+static value_t fl_memq(value_t *args, u_int32_t nargs)
+{
+    argcount("memq", nargs, 2);
+    while (iscons(args[1])) {
+        cons_t *c = (cons_t*)ptr(args[1]);
+        if (c->car == args[0])
+            return args[1];
+        args[1] = c->cdr;
+    }
+    return FL_F;
+}
+
+static value_t fl_exit(value_t *args, u_int32_t nargs)
 {
     if (nargs > 0)
         exit(tofixnum(args[0], "exit"));
@@ -34,7 +86,7 @@ value_t fl_exit(value_t *args, u_int32_t nargs)
     return NIL;
 }
 
-value_t fl_intern(value_t *args, u_int32_t nargs)
+static value_t fl_intern(value_t *args, u_int32_t nargs)
 {
     argcount("intern", nargs, 1);
     if (!isstring(args[0]))
@@ -42,7 +94,7 @@ value_t fl_intern(value_t *args, u_int32_t nargs)
     return symbol(cvalue_data(args[0]));
 }
 
-value_t fl_setconstant(value_t *args, u_int32_t nargs)
+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!");
@@ -55,7 +107,7 @@ value_t fl_setconstant(value_t *args, u_int32_t nargs)
 
 extern value_t LAMBDA;
 
-value_t fl_setsyntax(value_t *args, u_int32_t nargs)
+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!");
@@ -73,7 +125,7 @@ value_t fl_setsyntax(value_t *args, u_int32_t nargs)
     return args[1];
 }
 
-value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
+static value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
 {
     argcount("symbol-syntax", nargs, 1);
     symbol_t *sym = tosymbol(args[0], "symbol-syntax");
@@ -111,7 +163,7 @@ static void global_env_assoc_list(symbol_t *root, value_t *pv)
 
 extern symbol_t *symtab;
 
-value_t fl_syntax_env(value_t *args, u_int32_t nargs)
+static value_t fl_syntax_env(value_t *args, u_int32_t nargs)
 {
     (void)args;
     argcount("syntax-environment", nargs, 0);
@@ -130,7 +182,7 @@ value_t fl_global_env(value_t *args, u_int32_t nargs)
 
 extern value_t QUOTE;
 
-value_t fl_constantp(value_t *args, u_int32_t nargs)
+static value_t fl_constantp(value_t *args, u_int32_t nargs)
 {
     argcount("constant?", nargs, 1);
     if (issymbol(args[0]))
@@ -143,7 +195,7 @@ value_t fl_constantp(value_t *args, u_int32_t nargs)
     return FL_T;
 }
 
-value_t fl_integerp(value_t *args, u_int32_t nargs)
+static value_t fl_integerp(value_t *args, u_int32_t nargs)
 {
     argcount("integer?", nargs, 1);
     value_t v = args[0];
@@ -172,7 +224,7 @@ value_t fl_integerp(value_t *args, u_int32_t nargs)
     return FL_F;
 }
 
-value_t fl_fixnum(value_t *args, u_int32_t nargs)
+static value_t fl_fixnum(value_t *args, u_int32_t nargs)
 {
     argcount("fixnum", nargs, 1);
     if (isfixnum(args[0])) {
@@ -194,7 +246,7 @@ value_t fl_fixnum(value_t *args, u_int32_t nargs)
     lerror(ArgError, "fixnum: cannot convert argument");
 }
 
-value_t fl_truncate(value_t *args, u_int32_t nargs)
+static value_t fl_truncate(value_t *args, u_int32_t nargs)
 {
     argcount("truncate", nargs, 1);
     if (isfixnum(args[0]))
@@ -217,7 +269,7 @@ value_t fl_truncate(value_t *args, u_int32_t nargs)
     type_error("truncate", "number", args[0]);
 }
 
-value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
+static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
 {
     fixnum_t i;
     value_t f, v;
@@ -239,7 +291,7 @@ value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
     return v;
 }
 
-value_t fl_time_now(value_t *args, u_int32_t nargs)
+static value_t fl_time_now(value_t *args, u_int32_t nargs)
 {
     argcount("time.now", nargs, 0);
     (void)args;
@@ -258,7 +310,7 @@ static double todouble(value_t a, char *fname)
     type_error(fname, "number", a);
 }
 
-value_t fl_time_string(value_t *args, uint32_t nargs)
+static value_t fl_time_string(value_t *args, uint32_t nargs)
 {
     argcount("time.string", nargs, 1);
     double t = todouble(args[0], "time.string");
@@ -267,7 +319,7 @@ value_t fl_time_string(value_t *args, uint32_t nargs)
     return string_from_cstr(buf);
 }
 
-value_t fl_path_cwd(value_t *args, uint32_t nargs)
+static value_t fl_path_cwd(value_t *args, uint32_t nargs)
 {
     if (nargs > 1)
         argcount("path.cwd", nargs, 1);
@@ -282,7 +334,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs)
     return FL_T;
 }
 
-value_t fl_os_getenv(value_t *args, uint32_t nargs)
+static value_t fl_os_getenv(value_t *args, uint32_t nargs)
 {
     argcount("os.getenv", nargs, 1);
     char *name = tostring(args[0], "os.getenv");
@@ -293,7 +345,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs)
     return cvalue_static_cstring(val);
 }
 
-value_t fl_os_setenv(value_t *args, uint32_t nargs)
+static value_t fl_os_setenv(value_t *args, uint32_t nargs)
 {
     argcount("os.setenv", nargs, 2);
     char *name = tostring(args[0], "os.setenv");
@@ -310,7 +362,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
     return FL_T;
 }
 
-value_t fl_rand(value_t *args, u_int32_t nargs)
+static value_t fl_rand(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
     fixnum_t r;
@@ -321,7 +373,7 @@ value_t fl_rand(value_t *args, u_int32_t nargs)
 #endif
     return fixnum(r);
 }
-value_t fl_rand32(value_t *args, u_int32_t nargs)
+static value_t fl_rand32(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
     ulong r = random();
@@ -331,18 +383,18 @@ value_t fl_rand32(value_t *args, u_int32_t nargs)
     return mk_uint32(r);
 #endif
 }
-value_t fl_rand64(value_t *args, u_int32_t nargs)
+static value_t fl_rand64(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
     uint64_t r = (((uint64_t)random())<<32) | random();
     return mk_uint64(r);
 }
-value_t fl_randd(value_t *args, u_int32_t nargs)
+static value_t fl_randd(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
     return mk_double(rand_double());
 }
-value_t fl_randf(value_t *args, u_int32_t nargs)
+static value_t fl_randf(value_t *args, u_int32_t nargs)
 {
     (void)args; (void)nargs;
     return mk_float(rand_float());
@@ -365,6 +417,9 @@ static builtinspec_t builtin_info[] = {
     { "fixnum", fl_fixnum },
     { "truncate", fl_truncate },
     { "integer?", fl_integerp },
+    { "nconc", fl_nconc },
+    { "assq", fl_assq },
+    { "memq", fl_memq },
 
     { "vector.alloc", fl_vector_alloc },
 

femtolisp/cvalues.c

@@ -275,7 +275,7 @@ num_init(uint64, uint64, T_UINT64)
 num_init(float, double, T_FLOAT)
 num_init(double, double, T_DOUBLE)
 
-#define num_ctor(typenam, ctype, tag)                                   \
+#define num_ctor_init(typenam, ctype, tag)                              \
 value_t cvalue_##typenam(value_t *args, u_int32_t nargs)                \
 {                                                                       \
     if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; }             \
@@ -284,7 +284,9 @@ value_t cvalue_##typenam(value_t *args, u_int32_t nargs)                \
                               args[0], cp_data((cprim_t*)ptr(cp))))     \
         type_error(#typenam, "number", args[0]);                        \
     return cp;                                                          \
-}                                                                       \
+}
+
+#define num_ctor_ctor(typenam, ctype, tag)                              \
 value_t mk_##typenam(ctype##_t n)                                       \
 {                                                                       \
     value_t cp = cprim(typenam##type, sizeof(ctype##_t));               \
@@ -292,6 +294,10 @@ value_t mk_##typenam(ctype##_t n)                                       \
     return cp;                                                          \
 }
 
+#define num_ctor(typenam, ctype, tag) \
+    num_ctor_init(typenam, ctype, tag) \
+    num_ctor_ctor(typenam, ctype, tag)
+
 num_ctor(int8, int8, T_INT8)
 num_ctor(uint8, uint8, T_UINT8)
 num_ctor(int16, int16, T_INT16)
@@ -823,8 +829,20 @@ static value_t cvalue_array_aref(value_t *args)
 {
     char *data; ulong_t index;
     fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
-    value_t el = cvalue(eltype, eltype->size);
+    value_t el;
+    numerictype_t nt = eltype->numtype;
+    if (nt >= T_INT32)
+        el = cvalue(eltype, eltype->size);
     check_addr_args("aref", args[0], args[1], &data, &index);
+    if (nt < T_INT32) {
+        if (nt == T_INT8)
+            return fixnum((int8_t)data[index]);
+        else if (nt == T_UINT8)
+            return fixnum((uint8_t)data[index]);
+        else if (nt == T_INT16)
+            return fixnum(((int16_t*)data)[index]);
+        return fixnum(((uint16_t*)data)[index]);
+    }
     char *dest = cptr(el);
     size_t sz = eltype->size;
     if (sz == 1)

femtolisp/flisp.c

@@ -71,7 +71,7 @@ static char *builtin_names[] =
       "compare",
 
       // sequences
-      "vector", "aref", "aset!", "length", "assq", "for",
+      "vector", "aref", "aset!", "length", "for",
       "", "", "" };
 
 #define N_STACK 98304
@@ -608,20 +608,6 @@ int isnumber(value_t v)
 
 // eval -----------------------------------------------------------------------
 
-// return a cons element of v whose car is item
-static value_t assq(value_t item, value_t v)
-{
-    value_t bind;
-
-    while (iscons(v)) {
-        bind = car_(v);
-        if (iscons(bind) && car_(bind) == item)
-            return bind;
-        v = cdr_(v);
-    }
-    return FL_F;
-}
-
 /*
   take the final cdr as an argument so the list builtin can give
   the same result as (lambda x x).
@@ -1299,10 +1285,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
                 lerror(ArgError, "prog1: too few arguments");
             v = Stack[saveSP+1];
             break;
-        case F_ASSQ:
-            argcount("assq", nargs, 2);
-            v = assq(Stack[SP-2], Stack[SP-1]);
-            break;
         case F_FOR:
             argcount("for", nargs, 3);
             lo = tofixnum(Stack[SP-3], "for");

femtolisp/flisp.h

@@ -112,7 +112,7 @@ enum {
     F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
     F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
     F_COMPARE,
-    F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR,
+    F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
     F_TRUE, F_FALSE, F_NIL,
     N_BUILTINS,
 };

femtolisp/string.c

@@ -264,7 +264,7 @@ value_t fl_string_inc(value_t *args, u_int32_t nargs)
     while (cnt--) {
         if (i >= len)
             bounds_error("string.inc", args[0], args[1]);
-        u8_inc(s, &i);
+        (void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i);
     }
     return size_wrap(i);
 }
@@ -285,7 +285,7 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs)
     while (cnt--) {
         if (i == 0)
             bounds_error("string.dec", args[0], args[1]);
-        u8_dec(s, &i);
+        (void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i);
     }
     return size_wrap(i);
 }

femtolisp/system.lsp

@@ -60,14 +60,6 @@
 	(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
    #f))
 
-(define (nconc . lsts)
-  (cond ((null? lsts) ())
-        ((null? (cdr lsts)) (car lsts))
-        ((null? (car lsts)) (apply nconc (cdr lsts)))
-        (#t (prog1 (car lsts)
-		   (set-cdr! (last (car lsts))
-			     (apply nconc (cdr lsts)))))))
-
 (define (append . lsts)
   (cond ((null? lsts) ())
         ((null? (cdr lsts)) (car lsts))
@@ -81,10 +73,6 @@
   (cond ((atom? lst) #f)
         ((equal?     (car lst) item) lst)
         (#t          (member item (cdr lst)))))
-(define (memq item lst)
-  (cond ((atom? lst) #f)
-        ((eq?        (car lst) item) lst)
-        (#t          (memq item (cdr lst)))))
 (define (memv item lst)
   (cond ((atom? lst) #f)
         ((eqv?       (car lst) item) lst)
@@ -121,9 +109,6 @@
 
 (define (cadr x) (car (cdr x)))
 
-;(set! *special-forms* '(quote cond if and or while lambda trycatch
-;                        set! begin))
-
 (define (macroexpand e)
   ((label mexpand
           (lambda (e env f)
@@ -574,27 +559,27 @@
 
 (define (string.trim s at-start at-end)
   (define (trim-start s chars i L)
-    (if (and (< i L)
+    (if (and (#.< i L)
-	     (string.find chars (string.char s i)))
+	     (#.string.find chars (#.string.char s i)))
-	(trim-start s chars (string.inc s i) L)
+	(trim-start s chars (#.string.inc s i) L)
 	i))
   (define (trim-end s chars i)
     (if (and (> i 0)
-	     (string.find chars (string.char s (string.dec s i))))
+	     (#.string.find chars (#.string.char s (#.string.dec s i))))
-	(trim-end s chars (string.dec s i))
+	(trim-end s chars (#.string.dec s i))
 	i))
-  (let ((L (length s)))
+  (let ((L (#.length s)))
     (string.sub s
 		(trim-start s at-start 0 L)
 		(trim-end   s at-end   L))))
 
 (define (string.map f s)
   (let ((b (buffer))
-	(n (length s)))
+	(n (#.length s)))
     (let ((i 0))
-      (while (< i n)
+      (while (#.< i n)
-	     (begin (io.putc b (f (string.char s i)))
+	     (begin (#.io.putc b (f (#.string.char s i)))
-		    (set! i (string.inc s i)))))
+		    (set! i (#.string.inc s i)))))
     (io.tostring! b)))
 
 (define (print-to-string v)

femtolisp/todo

@@ -137,6 +137,8 @@ for internal use:
   instead, unless the value is part of an aggregate (e.g. struct).
   . this avoids allocating a new type for every size.
   . and/or add function array.alloc
+x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
+  . this made no difference in a string.map microbenchmark
 
 bugs:
 * with the fully recursive (simpler) relocate(), the size of cons chains
@@ -957,8 +959,6 @@ consolidated todo list as of 8/30:
 - eliminate string copy in lerror() when possible
 * fix printing lists of short strings
 
-- preallocate all byte,int8,uint8 values, and some wchars
-
 - remaining c types
 - remaining cvalues functions
 - finish ios