forge/sf: fixes, improvements; work in progress: if, while, ...

forge/sf.lisp

@@ -11,11 +11,13 @@
            #:word #:comp-word
            #:exec-list #:exec-input #:comp-input #:call
            #:comp-item
-           #:lit #:reg #:reg2 #:reg-code
+           #:next #:reg #:reg2 #:reg-code
            #:pushd #:popd #:peekd))
 
 (in-package :scopes/forge/sf)
 
+;;;; common definitions
+
 (defclass forge-env ()
   ((vocabulary :reader vocabulary :initform (make-hash-table))
    (func-index :reader func-index :initform (make-hash-table))
@@ -33,8 +35,6 @@
       (print-unreadable-object (fn s) (format s "~s" sym))
       (call-next-method))))
 
-;;;; core definitions
-
 (defgeneric exec-item (it)
   (:method ((it t))
     (pushd it))
@@ -45,7 +45,7 @@
 
 (defgeneric comp-item (it)
   (:method ((it t))
-    (push #'lit *buffer*)
+    (push #'next *buffer*)
     (push it *buffer*))
   (:method ((it symbol))
     (let ((v (find-word it)))
@@ -54,9 +54,12 @@
         (comp-item v)))))
 
 (defun find-word (sym)
-  (gethash sym (vocabulary *forge-env*)))
+  (multiple-value-bind (val found) (gethash sym (vocabulary *forge-env*))
+    (when (not found)
+      (util:lgw "not found" sym))
+    val))
 
-;;;; class word*
+;;;; class word
 
 (defclass word () 
   ((func :reader func :initarg :func)))
@@ -74,10 +77,10 @@
 (defmethod comp-item ((w comp-word))
   (funcall (func w)))
 
-;;;; functions
+;;;; code compilation and execution
 
 (defun exec-list (lst)
-  (let ((*input* (make-instance 'iter:list-iterator :data lst)))
+  (let ((*input* (iter:list-iterator lst)))
     (exec-input)))
 
 (defun exec-input ()
@@ -89,9 +92,11 @@
     (pushd (reverse *buffer*))))
 
 (defun call (code)
-  (let ((*code* (make-instance 'iter:list-iterator :data code)))
-    (util:lgi code)
-    (iter:process *code* #'funcall)))
+  (util:lgi code)
+  (let ((*code* code))
+    (do ((fn (pop *code*) (pop *code*)))
+        ((null fn))
+      (funcall fn))))
 
 (defun reg (sym fn &optional (cls 'word))
   (setf (gethash sym (vocabulary *forge-env*)) (make-instance cls :func fn))
@@ -114,7 +119,7 @@
 (defun peekd ()
   (car (stack *forge-env*)))
 
-(defun lit () 
+(defun next () 
   (pushd (iter:next-value *code*)))
 
 ;;;; builtins
@@ -123,12 +128,28 @@
   (:use :common-lisp)
   (:local-nicknames (:f :scopes/forge/sf)
                     (:iter :scopes/util/iter))
-  (:export #:add #:mul #:dup #:swp #:in #:? #:lit 
-           #:comp-pop #:comp-in #:comp
+  (:export #:add #:mul #:dup #:swp 
+           #:in #:next 
+           #:call #:comp 
            #:<comp #:reg #:regc #:/>))
 
 (in-package :sf-builtin)
 
+;;;; implementation functions
+
+(defun call-if ()
+  (let ((code (f:popd)))
+    (if (f:popd)
+      (f:call code))))
+
+(defun call-while ()
+  (let ((code (f:popd)))
+    (do ((cond (f:popd) (f:popd)))
+        ((not cond))
+      (f:call code))))
+
+;;;; lisp-code word definitions
+
 (f:reg2 'add #'+)
 (f:reg2 'mul #'*)
 
@@ -136,11 +157,10 @@
 (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 'next #'f:next)
 
-(f:reg 'comp-pop #'(lambda () (f:comp-item (popd))))
-(f:reg 'comp-in #'(lambda () (f:comp-item (iter:next-value f:*input*))))
-(f:reg 'comp #'(lambda () (f:comp-item (iter:next-value f:*code*))))
+(f:reg 'call #'(lambda () (f:call (popd))))
+(f:reg 'comp #'(lambda () (f:comp-item (popd))))
 
 (f:reg '<comp #'f:comp-input)
 
@@ -148,3 +168,5 @@
 (f:reg 'regc #'(lambda () (f:reg-code 'f:comp-word)))
 
 (f:reg '/> #'(lambda () (iter:stop f:*input*)) 'f:comp-word)
+
+;;;; forge-code word definitions

test/test-core.lisp

@@ -87,7 +87,7 @@
   )
 
 (deftest test-util-iter ()
-  (let ((it (make-instance 'iter:list-iterator :data '(1 2 3))))
+  (let ((it (iter:list-iterator '(1 2 3))))
     (== (iter:value it) nil))
   )
 

util/iter.lisp

@@ -40,6 +40,9 @@
   ((data :reader data :initarg :data :initform nil)
    (cur :accessor cur)))
 
+(defun list-iterator (data)
+  (make-instance 'list-iterator :data data))
+
 (defmethod initialize-instance :after ((it list-iterator) &key)
   (setf (cur it) (cons nil (data it))))