fixing trace and untrace

replacing function->vector with function:code, function:vals, and
  function:env

femtolisp/compiler.lsp

@@ -446,10 +446,9 @@
       (begin (disassemble f 0)
 	     (newline)
 	     (return #t)))
-  (let ((fvec (function->vector f))
+  (let ((lev (car lev?))
-	(lev (car lev?)))
+	(code (function:code f))
-    (let ((code (aref fvec 0))
+	(vals (function:vals f)))
-	  (vals (aref fvec 1)))
     (define (print-val v)
       (if (and (function? v) (not (builtin? v)))
 	  (begin (princ "\n")
@@ -496,6 +495,6 @@
 		  (princ "@" (hex5 (ref-uint32-LE code i)))
 		  (set! i (+ i 4)))
 		 
-		   (else #f))))))))
+		 (else #f)))))))
 
 #t

femtolisp/flisp.boot

@@ -5,11 +5,13 @@ vector.map
 vector->list
 #function("n1b0d1e031^p43;" [#function("q`e0b0lr2e1;" [#function("n1f10f00e0uZf01Kj01;" [])]) length])
 untrace
-#function("n1b0d1e031p42;" [#function("qe0Mb0<6T0d1f00d2d3d4d5e03131313142;];" [trace-lambda set-top-level-value! cadr caar last-pair caddr]) top-level-value])
+#function("n1b0d1e031p42;" [#function("qd0e0316K0d1f00d2e031a2Z42;];" [traced? set-top-level-value! function:vals]) top-level-value])
 transpose
 #function("n1d0d1e0s3;" [mapcar list])
+traced?
+#function("n1d0e031d0f0031>;" [function:code] #0=[#function("o0d0b1e0K312b2e0s2;" [println x #.apply] #0#) ()])
 trace
-#function("n1b0d1e031p322b2;" [#function("qb0d1e031p42;" [#function("qb0d1e031p42;" [#function("qf10Mb0<@6\x920d1f20b0f00d2b3L1b4b5L2L1b6b7f20L2L2L1d8d9b:le03231b4b;L2L1d2b7f10L2L1d8e03132L136L342;];" [trace-lambda set-top-level-value! nconc begin princ "(" print quote copy-list map #function("n1b0b1b2L2b3e0L2L3;" [begin princ " " print]) ")\n"]) to-proper]) cadr]) top-level-value ok])
+#function("n1b0d1e031p322b2;" [#function("qb0d130p42;" [#function("qd0f0031@6p0d1f10d2b3e0b4b5b6b7f10L2e0L3L2b8b7f00L2e0L3L3L33142;];" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok])
 to-proper
 #function("n1e0A6;0e0;e0?6F0e0L1;e0Md0e0N31K;" [to-proper])
 table.values
@@ -201,7 +203,7 @@ emit
 display
 #function("n1d0e0312\\;" [princ])
 disassemble
-#function("o1e1A6J0d0e0_322d1302\\;5K0]2b2d3e031e1Mp43;" [disassemble newline #function("qb0e0_Ze0`Zp43;" [#function("qb0]p42;" [#function("qb0li02b1_d2f0031p43;" [#function("n1e0J16>02e0G@6T0d0b1312d2e0f21`t42;d3e041;" [princ "\n" disassemble print]) #function("q]e0e1W6M02b0d1b2l]d333p32520;" [#function("qd0f00_326C0d1305D0]2_f31`ub2lr2d3d4f0031b5d6d7e031`32b8342f00`tj002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ":  " string.tail string "\t" #function("qd0e0b1326Z0f20f31d2f30f1032Z312f10a4tj10;d0e0b3326\x7f0f20f31f30f10ZZ312f10`tj10;d0e0b4326\xa30d5d6f30f10Z31312f10`tj10;d0e0b7326\xe20d5d6f30f10Z31b8322f10`tj102d5d6f30f10Z31312f10`tj10;d0e0b9326\x0c0d5b:d;d<f30f103231322f10a2tj10;d0e0b=32661d5b:d;d2f30f103231322f10a4tj10;];" [memv (:loadv.l :loadg.l :setg.l) ref-uint32-LE (:loadv :loadg :setg) (:loada :seta :call :tcall :list :+ :- :* :/ :vector :argc :vargc :loadi8 :apply :tapply) princ number->string (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) table.foldl #function("n3e217J02e1f20f00Z<16J02e0;" []) Instructions]) length])])]) function->vector])
+#function("o1e1A6J0d0e0_322d1302\\;5K0]2b2e1Md3e031d4e031p44;" [disassemble newline #function("qb0]p42;" [#function("qb0li02b1_d2f0131p43;" [#function("n1e0J16>02e0G@6T0d0b1312d2e0f10`t42;d3e041;" [princ "\n" disassemble print]) #function("q]e0e1W6M02b0d1b2l]d333p32520;" [#function("qd0f00_326C0d1305D0]2_f20`ub2lr2d3d4f0031b5d6d7e031`32b8342f00`tj002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ":  " string.tail string "\t" #function("qd0e0b1326Z0f20f32d2f31f1032Z312f10a4tj10;d0e0b3326\x7f0f20f32f31f10ZZ312f10`tj10;d0e0b4326\xa30d5d6f31f10Z31312f10`tj10;d0e0b7326\xe20d5d6f31f10Z31b8322f10`tj102d5d6f31f10Z31312f10`tj10;d0e0b9326\x0c0d5b:d;d<f31f103231322f10a2tj10;d0e0b=32661d5b:d;d2f31f103231322f10a4tj10;];" [memv (:loadv.l :loadg.l :setg.l) ref-uint32-LE (:loadv :loadg :setg) (:loada :seta :call :tcall :list :+ :- :* :/ :vector :argc :vargc :loadi8 :apply :tapply) princ number->string (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) table.foldl #function("n3e217J02e1f21f00Z<16J02e0;" []) Instructions]) length])]) function:code function:vals])
 delete-duplicates
 #function("n1e0?6;0e0;b0e0Me0Np43;" [#function("qd0e0e1326C0d1e141;e0d1e131K;" [member delete-duplicates])])
 count

femtolisp/flisp.c

@@ -277,10 +277,10 @@ static uint32_t _gensym_ctr=0;
 // gensym names available at a time, mostly for compare()
 static char gsname[2][16];
 static int gsnameno=0;
-value_t gensym(value_t *args, uint32_t nargs)
+value_t fl_gensym(value_t *args, uint32_t nargs)
 {
+    argcount("gensym", nargs, 0);
     (void)args;
-    (void)nargs;
     gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
     gs->id = _gensym_ctr++;
     gs->binding = UNBOUND;
@@ -289,11 +289,6 @@ value_t gensym(value_t *args, uint32_t nargs)
     return tagptr(gs, TAG_SYM);
 }
 
-value_t fl_gensym()
-{
-    return gensym(NULL, 0);
-}
-
 char *symbol_name(value_t v)
 {
     if (ismanaged(v)) {
@@ -776,23 +771,21 @@ static value_t do_trycatch()
   - check arg counts
   - allocate vararg array
   - push closed env, set up new environment
-
-  ** need 'copyenv' instruction that moves env to heap, installs
-     heap version as the current env, and pushes the result vector.
-     this can be used to implement the copy-closure op in terms of
-     other ops. and it can be the first instruction in lambdas in
-     head position (let optimization).
 */
 static value_t apply_cl(uint32_t nargs)
 {
-    uint32_t i, n, ip, bp, envsz, captured, op;
+    // frame variables
-    fixnum_t s, lo, hi;
+    uint32_t i, n, ip, bp, captured;
-    int64_t accum;
+    fixnum_t s, hi;
     uint8_t *code;
-    value_t func, v, x, e;
+
-    value_t *lenv, *pv;
+    // temporary variables (not necessary to preserve across calls)
+    uint32_t op, envsz;
+    int64_t accum;
     symbol_t *sym;
     cons_t *c;
+    value_t func, v, x, e;
+    value_t *lenv, *pv;
 
  apply_cl_top:
     captured = 0;
@@ -1254,13 +1247,13 @@ static value_t apply_cl(uint32_t nargs)
             Stack[SP-1] = v;
             goto next_op;
         case OP_FOR:
-            lo = tofixnum(Stack[SP-3], "for");
+            s  = tofixnum(Stack[SP-3], "for");
             hi = tofixnum(Stack[SP-2], "for");
             //f = Stack[SP-1];
             v = FL_F;
             SP += 2;
             i = SP;
-            for(s=lo; s <= hi; s++) {
+            for(; s <= hi; s++) {
                 Stack[SP-2] = Stack[SP-3];
                 Stack[SP-1] = fixnum(s);
                 v = apply_cl(1);
@@ -1451,24 +1444,34 @@ static value_t fl_function(value_t *args, uint32_t nargs)
     return fv;
 }
 
-static value_t fl_function2vector(value_t *args, uint32_t nargs)
+static value_t fl_function_code(value_t *args, uint32_t nargs)
 {
-    argcount("function->vector", nargs, 1);
+    argcount("function:code", nargs, 1);
     value_t v = args[0];
-    if (!isclosure(v))
+    if (!isclosure(v)) type_error("function:code", "function", v);
-        type_error("function->vector", "function", v);
+    return fn_bcode(v);
-    value_t vec = alloc_vector(3, 0);
+}
-    function_t *fn = (function_t*)ptr(args[0]);
+static value_t fl_function_vals(value_t *args, uint32_t nargs)
-    vector_elt(vec,0) = fn->bcode;
+{
-    vector_elt(vec,1) = fn->vals;
+    argcount("function:vals", nargs, 1);
-    vector_elt(vec,2) = fn->env;
+    value_t v = args[0];
-    return vec;
+    if (!isclosure(v)) type_error("function:vals", "function", v);
+    return fn_vals(v);
+}
+static value_t fl_function_env(value_t *args, uint32_t nargs)
+{
+    argcount("function:env", nargs, 1);
+    value_t v = args[0];
+    if (!isclosure(v)) type_error("function:env", "function", v);
+    return fn_env(v);
 }
 
 static builtinspec_t core_builtin_info[] = {
     { "function", fl_function },
-    { "function->vector", fl_function2vector },
+    { "function:code", fl_function_code },
-    { "gensym", gensym },
+    { "function:vals", fl_function_vals },
+    { "function:env", fl_function_env },
+    { "gensym", fl_gensym },
     { "hash", fl_hash },
     { NULL, NULL }
 };

femtolisp/flisp.h

@@ -138,7 +138,6 @@ value_t fl_cons(value_t a, value_t b);
 value_t list2(value_t a, value_t b);
 value_t listn(size_t n, ...);
 value_t symbol(char *str);
-value_t fl_gensym();
 char *symbol_name(value_t v);
 value_t alloc_vector(size_t n, int init);
 size_t llength(value_t v);

femtolisp/read.c

@@ -600,7 +600,7 @@ static value_t do_read_sexpr(value_t label)
     case TOK_GENSYM:
         pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
         if (*pv == (value_t)HT_NOTFOUND)
-            *pv = gensym(NULL, 0);
+            *pv = fl_gensym(NULL, 0);
         return *pv;
     case TOK_DOUBLEQUOTE:
         return read_string();

femtolisp/system.lsp

@@ -458,29 +458,29 @@
 
 (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
 
+(letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
+						   (apply #.apply args)))))
+  (set! traced?
+	(lambda (f)
+	  (equal? (function:code f)
+		  (function:code sample-traced-lambda)))))
+
 (define (trace sym)
-  (let* ((lam  (top-level-value sym))
+  (let* ((func (top-level-value sym))
-	 (args (cadr lam))
+	 (args (gensym)))
-	 (al   (to-proper args)))
+    (if (not (traced? func))
-    (if (not (eq? (car lam) 'trace-lambda))
 	(set-top-level-value! sym
-	     `(trace-lambda ,args
+			      (eval
-	        (begin
+			       `(lambda ,args
-		  (princ "(")
+				  (begin (println (cons ',sym ,args))
-		  (print ',sym)
+					 (apply ',func ,args)))))))
-		  ,@(map (lambda (a)
-			   `(begin (princ " ")
-				   (print ,a)))
-			 al)
-		  (princ ")\n")
-		  (',lam ,@al))))))
   'ok)
 
 (define (untrace sym)
-  (let ((lam  (top-level-value sym)))
+  (let ((func (top-level-value sym)))
-    (if (eq? (car lam) 'trace-lambda)
+    (if (traced? func)
 	(set-top-level-value! sym
-	     (cadr (caar (last-pair (caddr lam))))))))
+			      (aref (function:vals func) 2)))))
 
 (define-macro (time expr)
   (let ((t0 (gensym)))

femtolisp/todo

@@ -1033,7 +1033,7 @@ new evaluator todo:
 - let eversion
 * have macroexpand use its own global syntax table
 * be able to create/load an image file
-- fix trace and untrace
+* fix trace and untrace
 - opcodes CAAR, CADR, CDAR, CDDR, LOADA0, LOADA1, LOADC00, LOADC01, LOADC10
 - EQTO N, compare directly to stored datum N
 - peephole opt