shithub: femtolisp

--- a/femtolisp/cvalues.c

+++ b/femtolisp/cvalues.c

@@ -43,14 +43,15 @@

     if (cv->flags.prim) {

         if (cv->flags.inlined)

-            return 2 + NWORDS(cv->flags.inllen);

-        return 3;

+            return CPRIM_NWORDS_INL + NWORDS(cv->flags.inllen);

+        return CPRIM_NWORDS;

     if (cv->flags.inlined) {

-        size_t s = 3 + NWORDS(cv->flags.inllen + cv->flags.cstring);

-        return (s < 5) ? 5 : s;

+        size_t s = CVALUE_NWORDS_INL +

+            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 @@

     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 @@

     PUSH(type);

     if (sz <= MAX_INL_SIZE) {

-        size_t nw = 3 + NWORDS(sz);

-        pcv = (cvalue_t*)alloc_words((nw < 5) ? 5 : nw);

+        size_t nw = CVALUE_NWORDS_INL + NWORDS(sz);

+        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 @@

     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;

--- a/femtolisp/equal.c

+++ b/femtolisp/equal.c

@@ -247,6 +247,8 @@

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

--- a/femtolisp/flisp.c

+++ b/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 @@

                 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 @@

             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");

@@ -1118,6 +1117,13 @@

                 PUSH(NIL);

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

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -58,9 +58,10 @@

 #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 @@

 #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 @@

 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

@@ -176,6 +178,13 @@

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

         unsigned long flagbits;

@@ -182,12 +191,15 @@

};

     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;

@@ -196,6 +208,9 @@

     value_t type;

     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)

--- a/femtolisp/system.lsp

+++ b/femtolisp/system.lsp

@@ -2,11 +2,8 @@

 ; 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

 ; body expressions as in Common Lisp.

@@ -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)))

-                (set 'e (apply f (cdr e))))

+                          (setq f (macrocallp 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)

--- /dev/null

+++ b/femtolisp/table.c

@@ -1,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;

+}

--- a/femtolisp/test.lsp

+++ b/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))))))

--- a/femtolisp/wt.lsp

+++ b/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)))