making list a builtin

increasing default heapsize, giving better performance

adding hexdump and int2str functions to llt

femtolisp/flisp.c

@@ -56,7 +56,7 @@ static char *builtin_names[] =
 
       "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
       "builtinp", "vectorp", "fixnump", "equal",
-      "cons", "car", "cdr", "rplaca", "rplacd",
+      "cons", "list", "car", "cdr", "rplaca", "rplacd",
       "eval", "eval*", "apply", "prog1", "raise",
       "+", "-", "*", "/", "<", "~", "&", "!", "$",
       "vector", "aref", "aset", "length", "assoc", "compare",
@@ -95,7 +95,7 @@ static unsigned char *fromspace;
 static unsigned char *tospace;
 static unsigned char *curheap;
 static unsigned char *lim;
-static uint32_t heapsize = 256*1024;//bytes
+static uint32_t heapsize = 512*1024;//bytes
 static uint32_t *consflags;
 
 // error utilities ------------------------------------------------------------
@@ -596,6 +596,31 @@ static value_t assoc(value_t item, value_t v)
     return NIL;
 }
 
+/*
+  take the final cdr as an argument so the list builtin can give
+  the same result as (lambda x x).
+
+  however, there is still one interesting difference.
+  (eq a (apply list a)) is always false for nonempty a, while
+  (eq a (apply (lambda x x) a)) is always true. the justification for this
+  is that a vararg lambda often needs to recur by applying itself to the
+  tail of its argument list, so copying the list would be unacceptable.
+*/
+static void list(value_t *pv, int nargs, value_t *plastcdr)
+{
+    cons_t *c;
+    int i;
+    *pv = cons_reserve(nargs);
+    c = (cons_t*)ptr(*pv);
+    for(i=SP-nargs; i < (int)SP; i++) {
+        c->car = Stack[i];
+        c->cdr = tagptr(c+1, TAG_CONS);
+        c++;
+    }
+    (c-1)->cdr = *plastcdr;
+    POPN(nargs);
+}
+
 #define eval(e)         (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0))
 #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1))
 #define tail_eval(xpr) do { SP = saveSP;  \
@@ -870,6 +895,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
             c->cdr = Stack[SP-1];
             v = tagptr(c, TAG_CONS);
             break;
+        case F_LIST:
+            if (nargs) {
+                Stack[saveSP] = v;
+                list(&v, nargs, &Stack[saveSP]);
+            }
+            // else v is already set to the final cdr, which is the result
+            break;
         case F_CAR:
             argcount("car", nargs, 1);
             v = car(Stack[SP-1]);
@@ -1255,18 +1287,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
                     PUSH(v);
                     Stack[saveSP] = cdr_(Stack[saveSP]);
                 }
-                nargs = SP-i;
+                if (SP > (uint32_t)i)
-                if (nargs) {
+                    list(&Stack[i-1], SP-i, &Stack[saveSP]);
-                    Stack[i-1] = cons_reserve(nargs);
-                    c = (cons_t*)ptr(Stack[i-1]);
-                    for(; i < (int)SP; i++) {
-                        c->car = Stack[i];
-                        c->cdr = tagptr(c+1, TAG_CONS);
-                        c++;
-                    }
-                    (c-1)->cdr = Stack[saveSP];
-                    POPN(nargs);
-                }
             }
         }
         if (__unlikely(iscons(*argsyms))) {

femtolisp/flisp.h

@@ -105,7 +105,7 @@ enum {
     // functions
     F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,
     F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL,
-    F_CONS, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
+    F_CONS, F_LIST, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
     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_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR,

femtolisp/system.lsp

@@ -2,8 +2,6 @@
 ; by Jeff Bezanson (C) 2008
 ; Distributed under the BSD License
 
-(setq list (lambda args args))
-
 ; 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.
@@ -18,7 +16,7 @@
                     (list 'lambda args (f-body body)))))
 
 (defmacro label (name fn)
-  (list (list 'lambda (cons name nil) (list 'setq name fn)) nil))
+  (list (list 'lambda (list name) (list 'setq name fn)) nil))
 
 ; support both CL defun and Scheme-style define
 (defmacro defun (name args . body)
@@ -463,11 +461,11 @@
                  (cons 'nconc forms)))))))
 
 (defun bq-bracket (x)
-  (cond ((atom x)                   (list cons (bq-process x) nil))
+  (cond ((atom x)                   (list list (bq-process x)))
-        ((eq (car x) '*comma*)      (list cons (cadr x)       nil))
+        ((eq (car x) '*comma*)      (list list (cadr x)))
         ((eq (car x) '*comma-at*)   (list 'copy-list (cadr x)))
         ((eq (car x) '*comma-dot*)  (cadr x))
-        (T                          (list cons (bq-process x) nil))))
+        (T                          (list list (bq-process x)))))
 
 ; bracket without splicing
 (defun bq-bracket1 (x)

llt/Makefile

@@ -2,7 +2,7 @@ CC = gcc
 
 SRCS = bitvector.c hashing.c socket.c timefuncs.c utils.c dblprint.c ptrhash.c \
 	utf8.c ios.c operators.c cplxprint.c dirpath.c htable.c \
-	bitvector-ops.c fp.c
+	bitvector-ops.c fp.c int2str.c dump.c
 OBJS = $(SRCS:%.c=%.o)
 DOBJS = $(SRCS:%.c=%.do)
 TARGET = libllt.a

llt/dump.c

@@ -0,0 +1,41 @@
+#include <stdlib.h>
+#include "dtypes.h"
+#include "ios.h"
+#include "utils.h"
+
+static char hexdig[] = "0123456789abcdef";
+
+/*
+  display a given number of bytes from a buffer, with the first
+  address label being startoffs
+*/
+void hexdump(ios_t *dest, char *buffer, size_t len, size_t startoffs)
+{
+    size_t offs=0;
+    size_t i, pos, nc;
+    char ch, linebuffer[16];
+    char hexc[4];
+
+    hexc[2] = hexc[3] = ' ';
+    do {
+        ios_printf(dest, "%.8x  ", offs+startoffs);
+        pos = 10;
+        for(i=0; i < 16 && (offs+i) < len; i++) {
+            ch = buffer[offs + i];
+            linebuffer[i] = (ch<32 || ch>=0x7f) ? '.' : ch;
+            hexc[0] = hexdig[((unsigned char)ch)>>4];
+            hexc[1] = hexdig[ch&0x0f];
+            nc = (i==7 || i==15) ? 4 : 3;
+            ios_write(dest, hexc, nc);
+            pos += nc;
+        }
+        for(; i < 16; i++)
+            linebuffer[i] = ' ';
+        for(i=0; i < 60-pos; i++)
+            ios_putc(' ', dest);
+        ios_putc('|', dest);
+        ios_write(dest, linebuffer, 16);
+        ios_write(dest, "|\n", 2);
+        offs += 16;
+    } while (offs < len);
+}

llt/int2str.c

@@ -0,0 +1,25 @@
+#include <stdlib.h>
+#include "dtypes.h"
+
+char *int2str(char *dest, size_t n, long num, uint32_t base)
+{
+    int i = n-1;
+    int b = (int)base;
+    int neg = (num<0 ? 1 : 0);
+    char ch;
+    dest[i--] = '\0';
+    while (i >= 0) {
+        ch = (char)(num % b);
+        if (ch < 10)
+            ch += '0';
+        else
+            ch = ch-10+'a';
+        dest[i--] = ch;
+        num /= b;
+        if (num == 0)
+            break;
+    }
+    if (i >= 0 && neg)
+        dest[i--] = '-';
+    return &dest[i+1];
+}

llt/ios.h

@@ -103,6 +103,8 @@ int ios_pututf8(ios_t *s, uint32_t wc);
 int ios_putstringz(ios_t *s, char *str, bool_t do_write_nulterm);
 int ios_printf(ios_t *s, char *format, ...);
 
+void hexdump(ios_t *dest, char *buffer, size_t len, size_t startoffs);
+
 /* high-level stream functions - input */
 int ios_getnum(ios_t *s, char *data, uint32_t type);
 int ios_getutf8(ios_t *s, uint32_t *pwc);

llt/utils.h

@@ -45,6 +45,8 @@ void snprint_cplx(char *s, size_t cnt, double re, double im,
                   // print spaces around sign in a+bi
                   int spflag);
 
+char *int2str(char *dest, size_t n, long num, uint32_t base);
+
 extern double trunc(double x);
 
 STATIC_INLINE double fpart(double arg)