forge rewrite: basic interpreter / compiler working

forge/forge.lisp

@@ -6,10 +6,17 @@
   (:use :common-lisp)
   (:export #:*forge-env*
            #:forge-env #:dstack #:exec #:exec-str #:repl
-           #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
+           #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add
+           #:add))
 
 (in-package :scopes/forge)
 
+;;; builtins
+
+(defvar add #'(lambda () (pushd (cl:+ (popd) (popd)))))
+
+(defvar lit #'(lambda () (pushd (isq-next (ip *forge-env*)))))
+
 ;;; iseq: iterable sequence
 
 (defclass iseq ()
@@ -62,40 +69,35 @@
   (exec (read-from-string 
              (concatenate 'string "(" s ")"))))
 
-(defun exec (code)
-  (dolist (x code)
-    (typecase x
-      (symbol (funcall (comp1 x)))
-      (compiled-function (funcall x))
-      (t (pushd x)))))
-
-(defun call (code)
-  (dolist (x code)
-    (funcall x)))
-
 (defun repl ()
   (do ((input (read-line) (read-line))) ((string= input "q") nil)
     (exec-str input)))
 
-(defun find-word (key))
+(defun exec (code)
+  (call (comp code)))
 
-(defun comp (inp)
-  (let ((code nil))
-    (dolist (item inp)
-      (setf code (cons (comp1 item) code)))
-    (reverse code)))
+(defun call (code)
+  (let ((ip (make-iseq code)))
+    (setf (ip *forge-env*) ip)
+    (do ((item (isq-next ip) (isq-next ip)))
+        ((null item))
+      (funcall item))))
+
+(defun comp (slist)
+  (setf (cp *forge-env*) (make-iseq))
+  (let ((inp (make-iseq slist)))
+    (do ((item (isq-next inp) (isq-next inp))) 
+        ((null item))
+      (typecase item
+        (symbol (comp1 (symbol-value item)))
+        (cons (comp1 lit) (comp1 (comp item)))
+        (t (comp1 lit) (comp1 item)))))
+  (isq-all (cp *forge-env*)))
 
 (defun comp1 (item)
-  (typecase item
-    (symbol (find-word item))
-    (cons (comp item))
-    (t item)))
+  (isq-add (cp *forge-env*) item))
 
-(defun register (voc key fn)
-  (let ((k (if (symbolp key) (symbol-name key) key)))
-    (setf (gethash (string-downcase k) voc) fn)))
-
-; internal definitions
+;;; internal definitions
 
 (defun popd () (pop (data-stack *forge-env*)))
 

test/test-forge.lisp

@@ -14,7 +14,7 @@
 (defun run ()
   (let ((t:*test-suite* (t:test-suite "forge")))
     (test-iseq)
-    ;(test-exec)
+    (test-exec)
     ;(format t "~%data-stack ~a" (dstack))
     (t:show-result)))
 
@@ -26,5 +26,5 @@
     (== (forge:isq-end seq) 2)))
 
 (deftest test-exec ()
-  (forge:exec '(4 2 +))
+  (forge:exec '(4 2 forge:add))
   (== (car (forge:dstack)) 6))