From aa8017be9c381ea3a471ccce93f679bfa1942c04 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Tue, 10 Sep 2024 15:46:22 +0200
Subject: [PATCH] forge/sf: register compiler words; reverse word index: use
 for printing functions

---
 forge/sf.lisp     | 33 +++++++++++++++++++++++----------
 test/test-sf.lisp |  5 +++--
 2 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/forge/sf.lisp b/forge/sf.lisp
index e87e909..52c801a 100644
--- a/forge/sf.lisp
+++ b/forge/sf.lisp
@@ -6,8 +6,9 @@
   (:use :common-lisp)
   (:local-nicknames (:iter :scopes/util/iter))
   (:export #:*input* #:*stack*
+           #:word #:comp-word
            #:exec-list #:exec-input #:comp-input #:call
-           #:lit #:reg #:reg2
+           #:lit #:reg #:reg2 #:reg-code
            #:pushd #:popd #:peekd))
 
 (in-package :scopes/forge/sf)
@@ -16,6 +17,13 @@
 (defvar *input* nil)
 (defvar *buffer* nil)
 (defvar *code* nil)
+(defvar *func-index* (make-hash-table))
+
+(defmethod print-object :around ((fn function) s)
+  (let ((sym (gethash fn *func-index*)))
+    (if sym
+      (print-unreadable-object (fn s) (format s "~s" sym))
+      (call-next-method))))
 
 ;;;; core definitions
 
@@ -32,7 +40,7 @@
   (:method ((it symbol))
     (comp-item (symbol-value it))))
 
-;;;; class word
+;;;; class word*
 
 (defclass word () 
   ((func :reader func :initarg :func)))
@@ -68,12 +76,18 @@
   (let ((*code* (make-instance 'iter:list-iterator :data code)))
     (iter:process *code* #'funcall)))
 
-(defun reg (sym fn)
-  (setf (symbol-value sym) (make-instance 'word :func fn)))
+(defun reg (sym fn &optional (cls 'word))
+  (setf (symbol-value sym) (make-instance cls :func fn))
+  (setf (gethash fn *func-index*) sym))
 
 (defun reg2 (sym fn)
   (reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
 
+(defun reg-code (&optional (cls 'word))
+  (let ((name (popd))
+        (code (popd)))
+    (reg name #'(lambda () (call code)) cls)))
+
 (defun pushd (v)
   (push v *stack*))
 
@@ -93,7 +107,7 @@
   (:local-nicknames (:f :scopes/forge/sf)
                     (:iter :scopes/util/iter))
   (:export #:add #:mul #:dup #:in #:? #:lit
-           #:<comp #:reg))
+           #:<comp #:reg #:regc #:/>))
 
 (in-package :sf-builtin)
 
@@ -108,8 +122,7 @@
 
 (f:reg '<comp #'f:comp-input)
 
-(f:reg 'reg 
-  #'(lambda () 
-    (let ((name (popd))
-          (code (popd)))
-      (f:reg name #'(lambda () (f:call code))))))
+(f:reg 'reg #'f:reg-code)
+(f:reg 'regc #'(lambda () (f:reg-code 'f:comp-word)))
+
+(f:reg '/> #'(lambda () (iter:stop f:*input*)) 'f:comp-word)
diff --git a/test/test-sf.lisp b/test/test-sf.lisp
index 82c88f5..d8b05e2 100644
--- a/test/test-sf.lisp
+++ b/test/test-sf.lisp
@@ -23,11 +23,12 @@
 (deftest test-exec ()
   ;(forge:exec-str "4 2 add")
   (forge:exec-list '(4 2 add))
-  (util:lgi forge:*stack*)
   (== (forge:popd) 6)
   (forge:exec-list '(<comp dup mul))
-  (forge:exec-list '(in square))
   (util:lgi forge:*stack*)
+  (forge:exec-list '(in square reg))
+  (forge:exec-list '(7 square))
+  (== (forge:popd) 49)
   (t:show-result))