From 4d2f6655ef7f473636f37c9d94c001da540f7e2c Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Thu, 23 May 2024 14:50:32 +0200
Subject: [PATCH] forge rewrite: improvements: get-symbol, access to cp, ip

---
 forge/forge.lisp     | 45 ++++++++++++++++++++++++--------------------
 test/test-forge.lisp |  2 +-
 2 files changed, 26 insertions(+), 21 deletions(-)

diff --git a/forge/forge.lisp b/forge/forge.lisp
index 51fe652..ffaeb37 100644
--- a/forge/forge.lisp
+++ b/forge/forge.lisp
@@ -6,17 +6,10 @@
   (: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
-           #:add))
+           #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-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 ()
@@ -46,16 +39,14 @@
 (defun isq-add (seq v)
   (setf (cdr (end seq)) (list v))
   (pop (end seq)))
-(defclass forge-env ()
-  ((data-stack :initform nil
-               :accessor data-stack)
-   (cp :initform (make-iseq)
-       :accessor cp)
-   (ip :initform (make-iseq)
-       :accessor ip)))
 
 ;;; forge environment
 
+(defclass forge-env ()
+  ((data-stack :initform nil :accessor data-stack)
+   (cp :initform (make-iseq))
+   (ip :initform (make-iseq))))
+
 (defun forge-env ()
   (let ((fe (make-instance 'forge-env)))
     fe))
@@ -65,6 +56,14 @@
 (defun dstack()
   (data-stack *forge-env*))
 
+;;; builtins
+
+(defvar add #'(lambda () (pushd (+ (popd) (popd)))))
+
+(defvar lit #'(lambda () (pushd (isq-next (fip)))))
+
+;;; compiler, interpreter
+
 (defun exec-str (s)
   (exec (read-from-string 
              (concatenate 'string "(" s ")"))))
@@ -78,24 +77,27 @@
 
 (defun call (code)
   (let ((ip (make-iseq code)))
-    (setf (ip *forge-env*) ip)
+    (setf (slot-value *forge-env* 'ip) ip)
     (do ((item (isq-next ip) (isq-next ip)))
         ((null item))
       (funcall item))))
 
+(defun get-word (sym)
+  (symbol-value (find-symbol (string sym) :scopes/forge)))
+
 (defun comp (slist)
-  (setf (cp *forge-env*) (make-iseq))
+  (setf (slot-value *forge-env* 'cp) (make-iseq))
   (let ((inp (make-iseq slist)))
     (do ((item (isq-next inp) (isq-next inp))) 
         ((null item))
       (typecase item
-        (symbol (comp1 (symbol-value item)))
+        (symbol (comp1 (get-word item)))
         (cons (comp1 lit) (comp1 (comp item)))
         (t (comp1 lit) (comp1 item)))))
-  (isq-all (cp *forge-env*)))
+  (isq-all (fcp)))
 
 (defun comp1 (item)
-  (isq-add (cp *forge-env*) item))
+  (isq-add (fcp) item))
 
 ;;; internal definitions
 
@@ -103,3 +105,6 @@
 
 (defun pushd (v) (push v (data-stack *forge-env*)))
 
+(defun fcp () (slot-value *forge-env* 'cp))
+
+(defun fip () (slot-value *forge-env* 'ip))
diff --git a/test/test-forge.lisp b/test/test-forge.lisp
index a73e7a5..b04f0e0 100644
--- a/test/test-forge.lisp
+++ b/test/test-forge.lisp
@@ -26,5 +26,5 @@
     (== (forge:isq-end seq) 2)))
 
 (deftest test-exec ()
-  (forge:exec '(4 2 forge:add))
+  (forge:exec-str "4 2 add")
   (== (car (forge:dstack)) 6))