From 98e9e5901758e228b941a8b16e163a66599e3d57 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Sat, 25 May 2024 08:49:13 +0200
Subject: [PATCH] forge: setup, register:  more improvements, refactoring,
 simplification

---
 forge/forge.lisp     | 63 ++++++++++++++++++++------------------------
 test/test-forge.lisp |  5 ++--
 2 files changed, 31 insertions(+), 37 deletions(-)

diff --git a/forge/forge.lisp b/forge/forge.lisp
index 31f0e01..0586ea7 100644
--- a/forge/forge.lisp
+++ b/forge/forge.lisp
@@ -4,7 +4,7 @@
 
 (defpackage :scopes/forge
   (:use :common-lisp)
-  (:export #:*forge-env* #:init-forge-env
+  (:export #:*forge-env* #:setup-builtins #:activate-package
            #:forge-env #:dstack #:exec #:exec-str #:repl
            #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
 
@@ -50,59 +50,59 @@
    (words :initform (make-hash-table))
    (comp-words :initform (make-hash-table))
    (packages :initform '(:sf-user :sf-builtin))
-   (current-package :initform :sf-user)
+   (current-package :initform :sf-builtin)
    (rp :initform (make-iseq))
    (cp :initform (make-iseq))
    (ip :initform (make-iseq))))
 
 (defun forge-env ()
-  (let ((fe (make-instance 'forge-env)))
-    fe))
+  (make-instance 'forge-env))
 
 (defvar *forge-env* (forge-env))
 
-(defun dstack()
-  (data-stack *forge-env*))
+(defun activate-package(p)
+  (let ((old (current-package)))
+    (setf (slot-value *forge-env* 'current-package) p)
+    old))
+
+(defun dstack() (data-stack *forge-env*))
 
 (defun words () (slot-value *forge-env* 'words))
 
-(defun set-word (w fn) (setf (gethash w (words)) fn))
-
 (defun comp-words () (slot-value *forge-env* 'comp-words))
 
-(defun set-comp-word (w fn) (setf (gethash w (comp-words)) fn))
+(defun register-comp-word (sym fn)
+    (register sym fn :slot 'comp-words))
 
-(defun register-comp-word (sym fn &optional p)
-  (let ((p (or p (current-package))))
-    (set-comp-word (intern (string sym) p) fn)))
-
-(defun register (sym fn &optional p)
-  (let ((p (or p (current-package))))
-    (set-word (intern (string sym) p) fn)))
-
-(defmacro reg (sym &body body)
-  `(register ',sym #'(lambda () ,@body) :sf-builtin))
+(defun register (sym fn &key package (slot 'words))
+  (let* ((p (or package (current-package)))
+         (w (intern (string sym) p))
+         (words (slot-value *forge-env* slot)))
+    (setf (gethash w words) fn)))
 
 ;;; builtins
 
+(defmacro reg (sym &body body)
+  `(register ',sym #'(lambda () ,@body)))
+
 (defvar lit #'(lambda () (pushd (isq-next (fip)))))
 
-(defun init-forge-env ()
+(defun setup-builtins ()
 
   (reg add (pushd (+ (popd) (popd))))
   (reg mul (pushd (* (popd) (popd))))
 
   (reg dup (pushd (car (dstack))))
 
-  (register 'lit lit :sf-builtin)
+  (register 'lit lit)
 
   (register-comp-word 'def
-  #'(lambda () 
-      (let* ((name (isq-next (frp)))
-             (code (comp (isq-next (frp)))))
-        (register name #'(lambda () (call code)))))
-  :sf-builtin)
-)
+    #'(lambda () 
+        (let* ((name (isq-next (frp)))
+               (code (comp (isq-next (frp)))))
+          (register name #'(lambda () (call code))))))
+
+  (activate-package :sf-user))
 
 ;;; compiler, interpreter
 
@@ -138,7 +138,7 @@
 
 (defun comp-symbol (sym)
   (let* ((w (get-word sym))
-         (comp-fn (get-comp-fn w)))
+         (comp-fn (gethash w (comp-words))))
     (if comp-fn
       (funcall comp-fn)
       (comp-item (gethash w (words))))))
@@ -153,9 +153,6 @@
         (if w 
           (return-from get-word w))))))
 
-(defun get-comp-fn (w)
-  (gethash w (comp-words)))
-
 ;;; internal definitions / forge-env pseudo-methods
 
 (defun popd () (pop (data-stack *forge-env*)))
@@ -172,7 +169,3 @@
 
 (defun current-package () (slot-value *forge-env* 'current-package))
 
-(defun activate-package(p)
-  (let ((old (current-package)))
-    (setf (slot-value *forge-env* 'current-package) p)
-    old))
diff --git a/test/test-forge.lisp b/test/test-forge.lisp
index 91239ee..2296f78 100644
--- a/test/test-forge.lisp
+++ b/test/test-forge.lisp
@@ -12,8 +12,9 @@
 (in-package :scopes/test-forge)
 
 (defun run ()
-  (let ((t:*test-suite* (t:test-suite "forge")))
-    (forge:init-forge-env)
+  (let ((t:*test-suite* (t:test-suite "forge"))
+        (forge:*forge-env* (forge:forge-env)))
+    (forge:setup-builtins)
     (test-iseq)
     (test-exec)
     ;(format t "~%data-stack ~a" (dstack))