forge/sf: tests, fixes - define wforge definition word

forge/sf.lisp

@@ -4,7 +4,8 @@
 
 (defpackage :scopes/forge/sf
   (:use :common-lisp)
-  (:local-nicknames (:iter :scopes/util/iter))
+  (:local-nicknames (:iter :scopes/util/iter)
+                    (:util :scopes/util))
   (:export #:*input* #:*stack*
            #:word #:comp-word
            #:exec-list #:exec-input #:comp-input #:call
@@ -31,14 +32,19 @@
   (:method ((it t))
     (pushd it))
   (:method ((it symbol))
-    (exec-item (symbol-value it))))
+    (let ((v (symbol-value it)))
+      (when v
+        (exec-item v)))))
 
 (defgeneric comp-item (it)
   (:method ((it t))
     (push #'lit *buffer*)
     (push it *buffer*))
   (:method ((it symbol))
-    (comp-item (symbol-value it))))
+    (let ((v (symbol-value it)))
+      (when v
+        (util:lgi it v)
+        (comp-item v)))))
 
 ;;;; class word*
 
@@ -74,6 +80,7 @@
 
 (defun call (code)
   (let ((*code* (make-instance 'iter:list-iterator :data code)))
+    (util:lgi code)
     (iter:process *code* #'funcall)))
 
 (defun reg (sym fn &optional (cls 'word))
@@ -84,7 +91,7 @@
   (reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
 
 (defun reg-code (&optional (cls 'word))
-  (let ((name (popd))
+  (let* ((name (popd))
          (code (popd)))
     (reg name #'(lambda () (call code)) cls)))
 
@@ -106,7 +113,7 @@
   (:use :common-lisp)
   (:local-nicknames (:f :scopes/forge/sf)
                     (:iter :scopes/util/iter))
-  (:export #:add #:mul #:dup #:in #:? #:lit
+  (:export #:add #:mul #:dup #:swp #:in #:? #:lit #:defer 
            #:<comp #:reg #:regc #:/>))
 
 (in-package :sf-builtin)
@@ -115,10 +122,12 @@
 (f:reg2 'mul #'*)
 
 (f:reg 'dup #'(lambda () (f:pushd (f:peekd))))
+(f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b))))
 
 (f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
 
 (f:reg 'lit #'f:lit)
+(f:reg 'defer #'(lambda () (push (iter:next-value f::*code*) f::*buffer*)))
 
 (f:reg '<comp #'f:comp-input)
 

test/test-sf.lisp

@@ -15,20 +15,24 @@
 
 (defun run ()
   (let ((t:*test-suite* (t:test-suite "forge/sf")))
-        ;(forge:*forge-env* (forge:forge-env)))
+    (unwind-protect
-    ;(setf forge:*forge-env* (forge:forge-env))
+      (progn
         ;(forge:setup-builtins)
-    (test-exec)))
+        (test-exec)
+        (test-def)))
+    (util:lgi forge:*stack*)
+    (t:show-result)))
  
 (deftest test-exec ()
   ;(forge:exec-str "4 2 add")
   (forge:exec-list '(4 2 add))
   (== (forge:popd) 6)
-  (forge:exec-list '(<comp dup mul))
+  (forge:exec-list '(<comp dup mul /> in square reg))
-  (util:lgi forge:*stack*)
-  (forge:exec-list '(in square reg))
   (forge:exec-list '(7 square))
-  (== (forge:popd) 49)
+  (== (forge:popd) 49))
-  (t:show-result))
-
 
+(deftest test-def ()
+  (forge:exec-list '(<comp in <comp swp reg /> in <def reg))
+  (forge:exec-list '(<def cube dup dup mul mul />))
+  (forge:exec-list '(3 cube))
+  (== (forge:popd) 27))

util/iter.lisp

@@ -29,8 +29,8 @@
 
 (defgeneric process (it fn)
   (:method ((it iterator) fn)
-    (do ((eoi (next it) (next it)))
+    (do ((eoi (next it) (or (stopped it) (next it))))
-        ((or eoi (stopped it)))
+        (eoi)
       (funcall fn (value it)))
     (setf (stopped it) nil)))