I decided it was rather random that set was the only function

that could access the current environment dynamically. It also
differed unnecessarily from common lisp set in this respect.

So now setq is a builtin special form that sets lexical or
global variables, and set is a function that sets global variables.

Rather than eliminate the power of the dynamic set, I extended it
by adding eval*, which evaluates its argument in the current
environment. The justification for this is that the interpreter
is already dynamic enough to allow it with no overhead, so the
ability might as well be exposed.

cleanup; removing some magic numbers

beginning hash tables

femtolisp/cvalues.c

@@ -43,14 +43,15 @@ static size_t cv_nwords(cvalue_t *cv)
 {
     if (cv->flags.prim) {
         if (cv->flags.inlined)
-            return 2 + NWORDS(cv->flags.inllen);
+            return CPRIM_NWORDS_INL + NWORDS(cv->flags.inllen);
-        return 3;
+        return CPRIM_NWORDS;
     }
     if (cv->flags.inlined) {
-        size_t s = 3 + NWORDS(cv->flags.inllen + cv->flags.cstring);
+        size_t s = CVALUE_NWORDS_INL +
-        return (s < 5) ? 5 : s;
+            NWORDS(cv->flags.inllen + cv->flags.cstring);
+        return (s < CVALUE_NWORDS) ? CVALUE_NWORDS : s;
     }
-    return 5;
+    return CVALUE_NWORDS;
 }
 
 void *cv_data(cvalue_t *cv)
@@ -84,7 +85,7 @@ value_t cvalue(value_t type, size_t sz)
 
     if (issymbol(type)) {
         cprim_t *pcp;
-        pcp = (cprim_t*)alloc_words(2 + NWORDS(sz));
+        pcp = (cprim_t*)alloc_words(CPRIM_NWORDS_INL + NWORDS(sz));
         pcp->flagbits = INITIAL_FLAGS;
         pcp->flags.inllen = sz;
         pcp->flags.inlined = 1;
@@ -94,14 +95,14 @@ value_t cvalue(value_t type, size_t sz)
     }
     PUSH(type);
     if (sz <= MAX_INL_SIZE) {
-        size_t nw = 3 + NWORDS(sz);
+        size_t nw = CVALUE_NWORDS_INL + NWORDS(sz);
-        pcv = (cvalue_t*)alloc_words((nw < 5) ? 5 : nw);
+        pcv = (cvalue_t*)alloc_words((nw < CVALUE_NWORDS) ? CVALUE_NWORDS : nw);
         pcv->flagbits = INITIAL_FLAGS;
         pcv->flags.inllen = sz;
         pcv->flags.inlined = 1;
     }
     else {
-        pcv = (cvalue_t*)alloc_words(5);
+        pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
         pcv->flagbits = INITIAL_FLAGS;
         pcv->flags.inlined = 0;
         pcv->data = malloc(sz);
@@ -138,7 +139,7 @@ value_t cvalue_from_ref(value_t type, void *ptr, size_t sz, value_t parent)
 
     PUSH(parent);
     PUSH(type);
-    pcv = (cvalue_t*)alloc_words(5);
+    pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
     pcv->flagbits = INITIAL_FLAGS;
     pcv->flags.inlined = 0;
     pcv->data = ptr;

femtolisp/equal.c

@@ -247,6 +247,8 @@ value_t compare(value_t a, value_t b)
 
 value_t equal(value_t a, value_t b)
 {
+    if (eq_comparable(a, b))
+        return (a == b) ? T : NIL;
     return (numval(compare(a,b))==0 ? T : NIL);
 }
 

femtolisp/flisp.c

@@ -58,12 +58,12 @@
 
 static char *builtin_names[] =
     { "quote", "cond", "if", "and", "or", "while", "lambda",
-      "trycatch", "%apply", "progn",
+      "trycatch", "%apply", "setq", "progn",
 
       "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
       "builtinp", "vectorp", "fixnump", "equal",
       "cons", "car", "cdr", "rplaca", "rplacd",
-      "eval", "apply", "set", "prog1", "raise",
+      "eval", "eval*", "apply", "prog1", "raise",
       "+", "-", "*", "/", "<", "~", "&", "!", "$",
       "vector", "aref", "aset", "length", "assoc", "compare",
       "for" };
@@ -700,6 +700,33 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
                 lerror(ArgError, "quote: expected argument");
             v = car_(Stack[saveSP]);
             break;
+        case F_SETQ:
+            e = car(Stack[saveSP]);
+            v = eval(car(cdr_(Stack[saveSP])));
+            pv = &Stack[penv];
+            while (1) {
+                f = *pv++;
+                while (iscons(f)) {
+                    if (car_(f)==e) {
+                        *pv = v;
+                        SP = saveSP;
+                        return v;
+                    }
+                    f = cdr_(f); pv++;
+                }
+                if (f == e) {
+                    *pv = v;
+                    SP = saveSP;
+                    return v;
+                }
+                if (f != NIL) pv++;
+                if (*pv == NIL) break;
+                pv = &vector_elt(*pv, 0);
+            }
+            sym = tosymbol(e, "setq");
+            if (sym->syntax != TAG_CONST)
+                sym->binding = v;
+            break;
         case F_LAMBDA:
             // build a closure (lambda args body . env)
             if (Stack[penv] != NIL) {
@@ -813,34 +840,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
             break;
 
         // ordinary functions
-        case F_SET:
-            argcount("set", nargs, 2);
-            e = Stack[SP-2];
-            pv = &Stack[penv];
-            while (1) {
-                v = *pv++;
-                while (iscons(v)) {
-                    if (car_(v)==e) {
-                        *pv = Stack[SP-1];
-                        SP=saveSP;
-                        return *pv;
-                    }
-                    v = cdr_(v); pv++;
-                }
-                if (v == e) {
-                    *pv = Stack[SP-1];
-                    SP=saveSP;
-                    return *pv;
-                }
-                if (v != NIL) pv++;
-                if (*pv == NIL) break;
-                pv = &vector_elt(*pv, 0);
-            }
-            sym = tosymbol(e, "set");
-            v = Stack[SP-1];
-            if (sym->syntax != TAG_CONST)
-                sym->binding = v;
-            break;
         case F_BOUNDP:
             argcount("boundp", nargs, 1);
             sym = tosymbol(Stack[SP-1], "boundp");
@@ -1119,6 +1118,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
                 v = eval_sexpr(v, SP-2, 1);
             }
             break;
+        case F_EVALSTAR:
+            argcount("eval*", nargs, 1);
+            e = Stack[SP-1];
+            if (selfevaluating(e)) { SP=saveSP; return e; }
+            SP = penv+2;
+            goto eval_top;
+            break;
         case F_RAISE:
             argcount("raise", nargs, 1);
             raise(Stack[SP-1]);

femtolisp/flisp.h

@@ -58,9 +58,10 @@ typedef struct _symbol_t {
 #define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
 #define isvector(x) (tag(x) == TAG_VECTOR)
 #define iscvalue(x) (tag(x) == TAG_CVALUE)
-#define selfevaluating(x) (tag(x)<0x6)
+#define selfevaluating(x) (tag(x)<6)
 // comparable with ==
-#define eq_comparable(a,b) (!(((a)|(b))&0x1))
+#define eq_comparable(a,b) (!(((a)|(b))&1))
+#define eq_comparablep(a) (!((a)&1))
 // doesn't lead to other values
 #define leafp(a) (((a)&3) != 3)
 
@@ -80,6 +81,7 @@ typedef struct _symbol_t {
 #define symbol_value(s) (((symbol_t*)ptr(s))->binding)
 #define ismanaged(v) ((((unsigned char*)ptr(v)) >= fromspace) && \
                       (((unsigned char*)ptr(v)) < fromspace+heapsize))
+#define isgensym(x)  (issymbol(x) && ismanaged(x))
 
 extern value_t Stack[];
 extern u_int32_t SP;
@@ -90,12 +92,12 @@ extern u_int32_t SP;
 enum {
     // special forms
     F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
-    F_TRYCATCH, F_SPECIAL_APPLY, F_PROGN,
+    F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN,
     // 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_EVAL, F_APPLY, F_SET, F_PROG1, F_RAISE,
+    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,
     N_BUILTINS
@@ -175,6 +177,13 @@ typedef struct {
 # endif
 #endif
 
+typedef struct {
+    void (*print)(ios_t *f, value_t v, int princ);
+    void (*relocate)(value_t old, value_t new);
+    void (*finalize)(value_t self);
+    void (*print_traverse)(value_t self);
+} cvtable_t;
+
 typedef struct {
     union {
         cvflags_t flags;
@@ -182,12 +191,15 @@ typedef struct {
     };
     value_t type;
     value_t deps;
+    //cvtable_t *vtable;
     // fields below are absent in inline-allocated values
     void *data;
     size_t len;      // length of *data in bytes
-    //cvtable_t *vtable;
 } cvalue_t;
 
+#define CVALUE_NWORDS 5
+#define CVALUE_NWORDS_INL 3
+
 typedef struct {
     union {
         cvflags_t flags;
@@ -197,6 +209,9 @@ typedef struct {
     void *data;
 } cprim_t;
 
+#define CPRIM_NWORDS 3
+#define CPRIM_NWORDS_INL 2
+
 #define cv_len(c)  ((c)->flags.inlined ? (c)->flags.inllen : (c)->len)
 #define cv_type(c) ((c)->type)
 #define cv_numtype(c) ((c)->flags.numtype)

femtolisp/system.lsp

@@ -2,10 +2,7 @@
 ; by Jeff Bezanson (C) 2008
 ; Distributed under the BSD License
 
-(set 'list (lambda args args))
+(setq list (lambda args args))
-
-(set-syntax 'setq (lambda (name val)
-                    (list set (list 'quote name) val)))
 
 ; convert a sequence of body statements to a single expression.
 ; this allows define, defun, defmacro, let, etc. to contain multiple
@@ -32,6 +29,8 @@
       (list 'setq name (car body))
     (cons 'defun (cons (car name) (cons (cdr name) body)))))
 
+(defun set (s v) (eval (list 'setq s (list 'quote v))))
+
 (defun identity (x) x)
 (setq null not)
 
@@ -50,7 +49,7 @@
         ((null (cdr lsts)) (car lsts))
         (T ((lambda (l d) (if (null l) d
                             (prog1 l
-                              (while (consp (cdr l)) (set 'l (cdr l)))
+                              (while (consp (cdr l)) (setq l (cdr l)))
                               (rplacd l d))))
             (car lsts) (apply nconc (cdr lsts))))))
 
@@ -98,8 +97,8 @@
             (progn
               (while (and (consp e)
                           (not (member (car e) env))
-                          (set 'f (macrocallp e)))
+                          (setq f (macrocallp e)))
-                (set 'e (apply f (cdr e))))
+                (setq e (apply f (cdr e))))
               (cond ((and (consp e)
                           (not (eq (car e) 'quote)))
                      (let ((newenv
@@ -199,7 +198,7 @@
   (prog1 lst
     (while (consp lst)
       (rplaca lst (f (car lst)))
-      (set 'lst (cdr lst)))))
+      (setq lst (cdr lst)))))
 
 (defun mapcar (f . lsts)
   ((label mapcar-
@@ -243,9 +242,9 @@
 (define (nreverse l)
   (let ((prev nil))
     (while (consp l)
-      (set 'l (prog1 (cdr l)
+      (setq l (prog1 (cdr l)
                 (rplacd l (prog1 prev
-                            (set 'prev l))))))
+                            (setq prev l))))))
     prev))
 
 (defmacro let* (binds . body)

femtolisp/table.c

@@ -0,0 +1,100 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/types.h>
+#include "llt.h"
+#include "flisp.h"
+
+/*
+  there are 2 kinds of hash tables (eq and equal), each with some
+  optimized special cases. here are the building blocks:
+
+  hash/compare function: (h1) eq (ptrhash) and (h2) equal (deep hash)
+  relocate: (r1) no relocate, (r2) relocate but no rehash, (r3) rehash
+
+  eq hash:
+  keys all eq_comparable, no gensyms: h1, r1
+  anything else: h1, r3
+
+  equal hash:
+  keys all eq_comparable, no gensyms: h1, r1
+  with gensyms: h1, r2
+  anything else: h2, r2
+*/
+
+typedef struct {
+    void *(*get)(void *t, void *key);
+    void (*remove)(void *t, void *key);
+    void **(*bp)(void *t, void *key);
+} table_interface_t;
+
+typedef struct {
+    table_interface_t *ti;
+    ulong_t nkeys;
+    ptrhash_t ht;
+} fltable_t;
+
+void print_htable(ios_t *f, value_t h, int princ)
+{
+}
+
+void free_htable(value_t self)
+{
+    fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));
+    ptrhash_free(&pt->ht);
+}
+
+void relocate_htable(value_t old, value_t new)
+{
+    fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));
+    ptrhash_t *h = &pt->ht;
+    size_t i;
+    for(i=0; i < h->size; i++) {
+        if (h->table[i] != PH_NOTFOUND)
+            h->table[i] = (void*)relocate((value_t)h->table[i]);
+    }
+}
+
+void rehash_htable(value_t old, value_t new)
+{
+}
+
+cvtable_t h_r1_vtable = { print_htable, NULL, free_htable };
+cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable };
+cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable };
+
+int ishashtable(value_t v)
+{
+    return 0;
+}
+
+value_t fl_table(value_t *args, u_int32_t nargs)
+{
+}
+
+value_t fl_hashtablep(value_t *args, u_int32_t nargs)
+{
+    return NIL;
+}
+
+value_t fl_hash_put(value_t *args, u_int32_t nargs)
+{
+    return NIL;
+}
+
+value_t fl_hash_get(value_t *args, u_int32_t nargs)
+{
+    return NIL;
+}
+
+value_t fl_hash_has(value_t *args, u_int32_t nargs)
+{
+    return NIL;
+}
+
+value_t fl_hash_delete(value_t *args, u_int32_t nargs)
+{
+    return NIL;
+}

femtolisp/test.lsp

@@ -3,7 +3,7 @@
 ;  (list list ''labl (list 'quote name) f))
 
 (defmacro labl (name f)
-  `(let (,name) (set ',name ,f)))
+  `(let (,name) (setq ,name ,f)))
 
 ;(define (reverse lst)
 ;  ((label rev-help (lambda (lst result)
@@ -204,3 +204,28 @@
 ;(tt)
 ;(tt)
 ;(tt)
+
+(defmacro delay (expr)
+  (let ((g (gensym)))
+    `(let ((,g ',g))
+       (lambda () (if (eq ,g ',g) (setq ,g ,expr) ,g)))))
+
+(defmacro accumulate-while (cnd what . body)
+  (let ((first (gensym))
+        (acc (gensym))
+        (forms (f-body body)))
+    `(let ((,first (prog1 (cons ,what nil) ,forms))
+           (,acc nil))
+       (setq ,acc ,first)
+       (while ,cnd
+         (progn (rplacd ,acc (cons ,what nil))
+                (setq ,acc (cdr ,acc))
+                ,forms))
+       ,first)))
+
+(defun map-indexed (f lst)
+  (if (atom lst) lst
+    (let ((i 0))
+      (accumulate-while (consp lst) (f (car lst) i)
+                        (setq lst (cdr lst))
+                        (setq i (1+ i))))))

femtolisp/wt.lsp

@@ -5,4 +5,4 @@
                         (progn ,@forms
                                (-loop-))
                       nil)))))
-(while (< i 10000000) (set 'i (+ i 1)))
+(while (< i 10000000) (setq i (+ i 1)))