shithub: femtolisp

Download patch

ref: b9a1be78a090a3d57e6da9b10a247c8292726068
parent: debf3fd5179629f8da5764b65ed3b870bab4cce5
author: JeffBezanson <[email protected]>
date: Thu Apr 9 12:09:02 EDT 2009 

implementing op_closure, fix to loadc/setc



--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1469,12 +1469,12 @@
 */
 static value_t apply_cl(uint32_t nargs)
 {
-    uint32_t i, n, ip, bp;
+    uint32_t i, n, ip, bp, envsz;
     fixnum_t s;
     int64_t accum;
     uint8_t op, *code;
     value_t func, v, bcode, x, e, ftl;
-    value_t *penv, *pvals;
+    value_t *penv, *pvals, *lenv, *pv;
     symbol_t *sym;
     cons_t *c;
 
@@ -1919,7 +1919,7 @@
         case OP_LOADC:
         case OP_SETC:
             s = code[ip++];
-            i = code[ip++];
+            i = code[ip++]+1;
             if (penv[0]==NIL) {
                 if (nargs > 0) {
                     // current frame has been captured
@@ -1928,7 +1928,7 @@
                 v = penv[1];
             }
             else {
-                v = penv[numval(penv[-1])-1];
+                v = penv[nargs+1];
             }
             while (s--)
                 v = vector_elt(v, vector_size(v)-1);
@@ -1939,6 +1939,40 @@
             break;
 
         case OP_CLOSURE:
+            // build a closure (lambda args body . env)
+            if (penv[0] != NIL) {
+                // save temporary environment to the heap
+                lenv = penv;
+                envsz = nargs+2;
+                pv = alloc_words(envsz + 1);
+                PUSH(tagptr(pv, TAG_VECTOR));
+                pv[0] = fixnum(envsz);
+                pv++;
+                while (envsz--)
+                    *pv++ = *lenv++;
+                // environment representation changed; install
+                // the new representation so everybody can see it
+                penv[0] = NIL;
+                penv[1] = Stack[SP-1];
+            }
+            else {
+                PUSH(penv[1]); // env has already been captured; share
+            }
+            c = (cons_t*)ptr(v=cons_reserve(3));
+            e = cdr_(Stack[SP-2]);  // closure to copy
+            //if (!iscons(e)) goto notpair;
+            c->car = COMPILEDLAMBDA;
+            c->cdr = tagptr(c+1, TAG_CONS); c++;
+            c->car = car_(e);      //argsyms
+            c->cdr = tagptr(c+1, TAG_CONS); c++;
+            e = cdr_(e);
+            //if (!iscons(e=cdr_(e))) goto notpair;
+            c->car = car_(e);      //body
+            c->cdr = Stack[SP-1];  //env
+            POP();
+            Stack[SP-1] = v;
+            break;
+
         case OP_TRYCATCH:
             break;
         }