From 192c6c0fb9d45224e64fa097fc0bf543f2330bc1 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Tue, 28 May 2024 09:39:29 +0200
Subject: [PATCH] forge: reg basically working

---
 forge/forge.lisp     | 38 +++++++++++++++++++++++++++++---------
 scopes-forge.asd     |  2 +-
 scopes.asd           |  4 ++--
 steps/steps.lisp     |  1 +
 test/test-forge.lisp |  3 ++-
 5 files changed, 35 insertions(+), 13 deletions(-)

diff --git a/forge/forge.lisp b/forge/forge.lisp
index 256c211..c89f189 100644
--- a/forge/forge.lisp
+++ b/forge/forge.lisp
@@ -95,6 +95,18 @@
 
   (register 'lit #'lit)
 
+  (register 'reg
+    #'(lambda ()
+        (let* ((name (popd))
+               (code (popd)))
+          (format t "~%~a ~a" name code)
+          (register name #'(lambda () (call code))))))
+
+  (register-comp-word 'quote
+    #'(lambda () 
+        (let ((w (read-next)))
+          (comp-item #'lit) (comp-item w))))
+
   (register-comp-word 'def
     #'(lambda () 
         (let* ((name (read-next))
@@ -119,25 +131,33 @@
 (defun call (code)
   (let ((ip (make-iseq code)))
     (setf (slot-value *forge-env* 'ip) ip)
+    (print (isq-all ip))
     (do ((item (isq-next ip) (isq-next ip)))
         ((null item))
       (funcall item))))
 
 (defun comp (slist)
-  (setf (slot-value *forge-env* 'cp) (make-iseq))
-  (let ((inp (make-iseq slist)))
-    (setf (slot-value *forge-env* 'rp) inp)
-    (do ((item (isq-next inp) (isq-next inp))) 
-        ((null item))
-      (typecase item
-        (symbol (comp-symbol item))
-        (cons (comp-item #'lit) (comp-item (comp item)))
-        (t (comp-item #'lit) (comp-item item)))))
+  (let ((cp (make-iseq)))
+    (setf (slot-value *forge-env* 'cp) cp)
+    (let ((inp (make-iseq slist)))
+      (setf (slot-value *forge-env* 'rp) inp)
+      (do ((item (isq-next inp) (isq-next inp)))
+          ((null item))
+        (print item)
+        (typecase item
+          (symbol (comp-symbol item))
+          (cons (comp-item #'lit) 
+                (let ((sub (comp item)))
+                  (setf (slot-value *forge-env* 'cp) cp)
+                  (setf (slot-value *forge-env* 'rp) inp)
+                  (comp-item sub)))
+          (t (comp-item #'lit) (comp-item item))))))
   (isq-all (fcp)))
 
 (defun comp-symbol (sym)
   (let* ((w (get-word sym))
          (comp-fn (gethash w (comp-words))))
+    (format t "~%~a ~a ~a" sym w comp-fn)
     (if comp-fn
       (funcall comp-fn)
       (comp-item (gethash w (words))))))
diff --git a/scopes-forge.asd b/scopes-forge.asd
index c4ac93b..c98e227 100644
--- a/scopes-forge.asd
+++ b/scopes-forge.asd
@@ -16,4 +16,4 @@
 (defsystem :scopes-forge/test
   :depends-on (:scopes-forge)
   :components ((:file "test/test-forge"))
-  :perform (test-op (o c) (funcall #'scopes/test-forge:run)))
+  :perform (test-op (o c) (symbol-call :scopes/test-forge :run)))
diff --git a/scopes.asd b/scopes.asd
index f7652d3..711b4c8 100644
--- a/scopes.asd
+++ b/scopes.asd
@@ -24,5 +24,5 @@
   :components ((:file "test/test-storage")
                (:file "test/test-forge"))
   :perform (test-op (o c) 
-    (funcall #'scopes/test-storage:run-all)
-    (funcall #'scopes/test-forge:run)))
+    (symbol-call :scopes/test-storage :run-all)
+    (symbol-call :scopes/test-forge :run)))
diff --git a/steps/steps.lisp b/steps/steps.lisp
index 796e5ac..6c2a9fa 100644
--- a/steps/steps.lisp
+++ b/steps/steps.lisp
@@ -5,3 +5,4 @@
 
 (in-package :scopes/steps)
 
+(defclass process ())
diff --git a/test/test-forge.lisp b/test/test-forge.lisp
index 3be31ff..fb7b1c7 100644
--- a/test/test-forge.lisp
+++ b/test/test-forge.lisp
@@ -33,6 +33,7 @@
   (== (car (forge:dstack)) 6))
 
 (deftest test-def ()
-  (forge:exec-str "def square (dup *)")
+  ;(forge:exec-str "def square (dup *)")
+  (forge:exec-str "(dup *) quote square reg")
   (forge:exec-str "7 square")
   (== (car (forge:dstack)) 49))