From 6ed436f94f3251f3ad4fc67acf0a94008282475d Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Tue, 17 Sep 2024 12:37:03 +0200
Subject: [PATCH] forge: make forge/sf the standard forge package; keep old
 files as x-... for reference

---
 forge/forge.lisp   | 336 +++++++++++++++++++++------------------------
 forge/sf.lisp      | 200 ---------------------------
 forge/x-forge.lisp | 224 ++++++++++++++++++++++++++++++
 3 files changed, 380 insertions(+), 380 deletions(-)
 delete mode 100644 forge/sf.lisp
 create mode 100644 forge/x-forge.lisp

diff --git a/forge/forge.lisp b/forge/forge.lisp
index be7ed83..ff3c50c 100644
--- a/forge/forge.lisp
+++ b/forge/forge.lisp
@@ -4,221 +4,197 @@
 
 (defpackage :scopes/forge
   (:use :common-lisp)
-  (: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
-           #:with-trace))
-
-(defpackage :sf-builtin)
-(defpackage :sf-user)
+  (:local-nicknames (:iter :scopes/util/iter)
+                    (:util :scopes/util))
+  (:export #:forge-env #:vocabulary #:stack #:current-package
+           #:*forge-env* #:*input* #:*code*
+           #:word #:comp-word
+           #:repl #:exec-list #:exec-string #:exec-input #:comp-input #:call
+           #:comp-item
+           #:next #:reg #:reg1 #:reg2 #:reg-code
+           #:pushd #:popd #:peekd))
 
 (in-package :scopes/forge)
 
-(defmacro with-trace (&body body)
-  `(let ((*features* (cons :forge-trace *features*))) ,@body))
-
-;;; iseq: iterable sequence
-
-(defclass iseq ()
-  ((start :reader start :initform (list nil) :initarg :start)
-   (cur :accessor cur)
-   (end :accessor end)))
-
-(defun make-iseq (&optional start)
-  (let* ((start (cons nil start))
-         (seq (make-instance 'iseq :start start)))
-    (setf (cur seq) (setf (end seq) start))
-    seq))
-
-(defun isq-all (seq)
-  (cdr (start seq)))
-
-(defun isq-cur (seq)
-  (car (cur seq)))
-
-(defun isq-end (seq)
-  (car (end seq)))
-
-(defun isq-next (seq)
-  (pop (cur seq))
-  (car (cur seq)))
-
-(defun isq-add (seq v)
-  (setf (cdr (end seq)) (list v))
-  (pop (end seq)))
-
-;;; forge environment
+;;;; common definitions
 
 (defclass forge-env ()
-  ((data-stack :initform nil :accessor data-stack)
-   (words :initform (make-hash-table :test #'eq))
-   (comp-words :initform (make-hash-table))
-   (words-rev :initform (make-hash-table))
-   (words-meta :initform (make-hash-table))
-   (packages :initform '(:sf-user :sf-builtin))
-   (current-package :initform :sf-builtin)
-   (ip :initform (make-iseq))
-   (rp) (cp)))
+  ((vocabulary :reader vocabulary :initform (make-hash-table))
+   (func-index :reader func-index :initform (make-hash-table))
+   (stack :accessor stack :initform nil)
+   (current-package :accessor current-package :initform :sf-builtin)))
 
-(defun forge-env ()
-  (make-instance 'forge-env))
+(defvar *forge-env* (make-instance 'forge-env))
 
-(defvar *forge-env* (forge-env))
+(defvar *input* nil)
+(defvar *buffer* nil)
+(defvar *code* nil)
 
-(defun activate-package(p)
-  (let ((old (current-package)))
-    (setf (slot-value *forge-env* 'current-package) p)
-    old))
+(defmethod print-object :around ((fn function) s)
+  (let ((sym (gethash fn (func-index *forge-env*))))
+    (if sym
+      (print-unreadable-object (fn s) (format s "~s" sym))
+      (call-next-method))))
 
-(defun dstack() (data-stack *forge-env*))
+(defgeneric exec-item (it)
+  (:method ((it t))
+    (pushd it))
+  (:method ((it symbol))
+    (let ((v (find-word it)))
+      (when v
+        (exec-item v)))))
 
-(defun words () (slot-value *forge-env* 'words))
+(defgeneric comp-item (it)
+  (:method ((it t))
+    (push #'next *buffer*)
+    (push it *buffer*))
+  (:method ((it symbol))
+    (let ((v (find-word it)))
+      (when v
+        ;(util:lgi it v)
+        (comp-item v)))))
 
-(defun comp-words () (slot-value *forge-env* 'comp-words))
+(defun find-word (sym)
+  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
+    (multiple-value-bind (val found) (gethash sym (vocabulary *forge-env*))
+      (when (not found)
+        (util:lgw "not found" sym))
+      val)))
 
-(defun register-comp-word (sym fn &key code)
-  (register sym fn :slot 'comp-words :code code))
+;;;; class word
 
-(defun register (sym fn &key (slot 'words) code)
-  (let* ((w (intern (string sym) (current-package)))
-         (words (slot-value *forge-env* slot)))
-    (setf (gethash w words) fn)
-    (setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
-    (if code
-      (setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
+(defclass word () 
+  ((func :reader func :initarg :func)))
 
-;;; builtins
+(defmethod exec-item ((w word))
+  (funcall (func w)))
 
-(defmacro reg (sym &body body)
-  `(register ',sym #'(lambda () ,@body)))
+(defmethod comp-item ((w word))
+  (push (func w) *buffer*))
 
-(defun lit () (pushd (isq-next (fip))))
+;;;; class comp-word
 
-(defun do-reg (&optional (fn #'register))
-  (let* ((name (popd))
-         (code (popd)))
-    (funcall fn name #'(lambda () (call code)) :code code)))
+(defclass comp-word (word) ())
 
-(defun do-quote () 
-  (let ((quoted (read-next)))
-    #+forge-trace (format t " - do-quote: ~a" quoted)
-    (comp-item #'lit) (comp-item quoted)))
+(defmethod comp-item ((w comp-word))
+  (funcall (func w)))
 
-(defun do-comp () 
-  (let* ((sym (read-next))
-         (w (get-word sym)))
-    ;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
-    (comp-item (gethash w (comp-words)))))
-
-(defun setup-builtins ()
-  (register 'lit #'lit)
-  (register 'reg #'do-reg)
-
-  (reg + (pushd (+ (popd) (popd))))
-  (reg * (pushd (* (popd) (popd))))
-  (reg dup (pushd (car (dstack))))
-  (reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
-  (reg ? (format t "~a~%" (popd)))
-  (reg ?? (format t "~a~%" (dstack)))
-  (reg get (pushd (cadr (popd))))
-  (reg set (setf (cadr (popd)) (popd)))
-  (reg wrap (pushd (list #'lit (popd))))
-  (reg defer (comp-item (isq-next (fip))))
-  (reg regc (do-reg #'register-comp-word))
-
-  (register-comp-word 'quote #'do-quote)
-  (register-comp-word 'comp #'do-comp)
-
-  (activate-package :sf-user))
-
-;;; trace functionality
-
-(defun decompile-item (item)
-  (or (gethash item (slot-value *forge-env* 'words-rev))
-      (typecase item
-        (cons (decompile item))
-        (t item))))
-
-(defun decompile (code)
-  (mapcar #'decompile-item code))
-
-(defun trace-call (code)
-  (format t "~%call: ~a" (decompile code)))
-
-;;; compiler, interpreter
-
-(defun exec-str (s)
-  (exec (read-from-string 
-             (concatenate 'string "(" s ")"))))
+;;;; code compilation and execution
 
 (defun repl ()
   (do ((input (read-line) (read-line))) 
-      ((string= input "q") (dstack))
-    (exec-str input)))
+      ((string= input "q") (stack *forge-env*))
+    (exec-string input)))
 
-(defun exec (code)
-  (call (comp code)))
+(defun exec-list (lst)
+  (let ((*input* (iter:list-iterator lst)))
+    (exec-input)))
+
+(defun exec-string (s)
+  (let ((*input* (iter:string-iterator s)))
+    (exec-input)))
+
+(defun exec-input ()
+  (iter:process *input* #'exec-item))
+
+(defun comp-input ()
+  (let ((*buffer* nil))
+    (iter:process *input* #'comp-item)
+    (pushd (reverse *buffer*))))
 
 (defun call (code)
-  #+forge-trace (trace-call code)
-  (let ((old-ip (fip))
-        (ip (make-iseq code)))
-    (setf (slot-value *forge-env* 'ip) ip)
-    (do ((item (isq-next ip) (isq-next ip)))
-        ((null item))
-      (funcall item))
-    (setf (slot-value *forge-env* 'ip) old-ip)
-    #+forge-trace (format t "~% - stack: ~A" (dstack))
-    (dstack)))
+  (util:lgi code)
+  (let ((*code* code))
+    (do ((fn (pop *code*) (pop *code*)))
+        ((null fn))
+      (funcall fn))))
 
-(defun comp (slist)
-  #+forge-trace (format t "~%comp: ~a" slist)
-  (let ((cp (make-iseq))
-        (inp (make-iseq slist)))
-    (setf (slot-value *forge-env* 'cp) cp)
-    (setf (slot-value *forge-env* 'rp) inp)
-    (do ((item (isq-next inp) (isq-next inp)))
-        ((null item))
-      (typecase item
-        (symbol (comp-symbol item))
-        (cons (let ((sub (comp item)))
-                (setf (slot-value *forge-env* 'cp) cp)
-                (setf (slot-value *forge-env* 'rp) inp)
-                (comp-item #'lit)
-                (comp-item sub)))
-        (t (comp-item #'lit) (comp-item item)))))
-  (isq-all (fcp)))
+(defun reg (sym fn &optional (cls 'word))
+  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
+    (setf (gethash sym (vocabulary *forge-env*)) (make-instance cls :func fn))
+    (setf (gethash fn (func-index *forge-env*)) sym)))
 
-(defun comp-symbol (sym)
-  (let* ((w (get-word sym))
-         (comp-fn (gethash w (comp-words))))
-    ;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
-    (if comp-fn
-      (funcall comp-fn)
-      (comp-item (gethash w (words))))))
+(defun reg1 (sym fn)
+  (reg sym #'(lambda () (pushd (funcall fn (popd))))))
 
-(defun get-word (sym)
-  (let ((name (string sym)))
-    (dolist (p (packages))
-      (let ((w (find-symbol name p)))
-        (if w 
-          (return-from get-word w))))))
+(defun reg2 (sym fn)
+  (reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
 
-;;; internal definitions / forge-env pseudo-methods
+(defun reg-code (&optional (cls 'word))
+  (let* ((name (popd))
+         (code (popd)))
+    (reg name #'(lambda () (call code)) cls)))
 
-(defun popd () (pop (data-stack *forge-env*)))
+(defun pushd (v)
+  (push v (stack *forge-env*)))
 
-(defun pushd (v) (push v (data-stack *forge-env*)))
+(defun popd ()
+  (pop (stack *forge-env*)))
 
-(defun fcp () (slot-value *forge-env* 'cp))
+(defun peekd ()
+  (car (stack *forge-env*)))
 
-(defun comp-item (item) (isq-add (fcp) item))
+(defun next () 
+  (pushd (pop *code*)))
 
-(defun fip () (slot-value *forge-env* 'ip))
+;;;; builtins
 
-(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
+(defpackage :sf-builtin
+  (:use :common-lisp)
+  (:local-nicknames (:f :scopes/forge)
+                    (:iter :scopes/util/iter)
+                    (:util :scopes/util))
+  (:export #:add #:mul #:drop #:dup #:swp 
+           #:? #:??
+           #:ptr #:get #:put
+           #:in #:next 
+           #:call #:call-if #:call-while #:val
+           #:<comp #:reg #:regc #:/>))
 
-(defun packages () (slot-value *forge-env* 'packages))
+(in-package :sf-builtin)
 
-(defun current-package () (slot-value *forge-env* 'current-package))
+;;;; implementation functions
 
+(defun call-if ()
+  (let ((code (f:popd)))
+    (if (f:popd)
+      (f:call code))))
+
+(defun call-while ()
+  (let ((code (f:popd)))
+    (do ((cond (f:popd) (f:popd)))
+        ((not cond))
+      (f:call code))))
+
+;;;; lisp-code word definitions
+
+(f:reg2 'add #'+)
+(f:reg2 'mul #'*)
+
+(f:reg 'dup #'(lambda () (f:pushd (f:peekd))))
+(f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b))))
+(f:reg 'drop #'f:popd)
+
+(f:reg '? #'(lambda () (format t "~a~%" (f:popd))))
+(f:reg '?? #'(lambda () (format t "~a~%" (f:stack f:*forge-env*))))
+
+(f:reg1 'ptr #'util:ptr)
+(f:reg1 'get #'aref)
+(f:reg 'put #'(lambda () (setf (aref (f:popd)) (f:popd))))
+
+(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
+(f:reg 'next #'f:next)
+
+(f:reg 'call #'(lambda () (f:call (popd))))
+(f:reg 'call-if #'call-if)
+(f:reg 'call-while #'call-while)
+(f:reg 'val #'(lambda () (f:pushd (list #'f:next (f:popd)))))
+
+(f:reg '<comp #'f:comp-input)
+
+(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)
+
+;;;; forge-code word definitions
diff --git a/forge/sf.lisp b/forge/sf.lisp
deleted file mode 100644
index 158820c..0000000
--- a/forge/sf.lisp
+++ /dev/null
@@ -1,200 +0,0 @@
-;;;; cl-scopes/forge - may the forge be with you!
-
-;;;; A Forth-like interpreter implemented in Common Lisp.
-
-(defpackage :scopes/forge/sf
-  (:use :common-lisp)
-  (:local-nicknames (:iter :scopes/util/iter)
-                    (:util :scopes/util))
-  (:export #:forge-env #:vocabulary #:stack #:current-package
-           #:*forge-env* #:*input* #:*code*
-           #:word #:comp-word
-           #:repl #:exec-list #:exec-string #:exec-input #:comp-input #:call
-           #:comp-item
-           #:next #:reg #:reg1 #:reg2 #:reg-code
-           #:pushd #:popd #:peekd))
-
-(in-package :scopes/forge/sf)
-
-;;;; common definitions
-
-(defclass forge-env ()
-  ((vocabulary :reader vocabulary :initform (make-hash-table))
-   (func-index :reader func-index :initform (make-hash-table))
-   (stack :accessor stack :initform nil)
-   (current-package :accessor current-package :initform :sf-builtin)))
-
-(defvar *forge-env* (make-instance 'forge-env))
-
-(defvar *input* nil)
-(defvar *buffer* nil)
-(defvar *code* nil)
-
-(defmethod print-object :around ((fn function) s)
-  (let ((sym (gethash fn (func-index *forge-env*))))
-    (if sym
-      (print-unreadable-object (fn s) (format s "~s" sym))
-      (call-next-method))))
-
-(defgeneric exec-item (it)
-  (:method ((it t))
-    (pushd it))
-  (:method ((it symbol))
-    (let ((v (find-word it)))
-      (when v
-        (exec-item v)))))
-
-(defgeneric comp-item (it)
-  (:method ((it t))
-    (push #'next *buffer*)
-    (push it *buffer*))
-  (:method ((it symbol))
-    (let ((v (find-word it)))
-      (when v
-        ;(util:lgi it v)
-        (comp-item v)))))
-
-(defun find-word (sym)
-  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
-    (multiple-value-bind (val found) (gethash sym (vocabulary *forge-env*))
-      (when (not found)
-        (util:lgw "not found" sym))
-      val)))
-
-;;;; class word
-
-(defclass word () 
-  ((func :reader func :initarg :func)))
-
-(defmethod exec-item ((w word))
-  (funcall (func w)))
-
-(defmethod comp-item ((w word))
-  (push (func w) *buffer*))
-
-;;;; class comp-word
-
-(defclass comp-word (word) ())
-
-(defmethod comp-item ((w comp-word))
-  (funcall (func w)))
-
-;;;; code compilation and execution
-
-(defun repl ()
-  (do ((input (read-line) (read-line))) 
-      ((string= input "q") (stack *forge-env*))
-    (exec-string input)))
-
-(defun exec-list (lst)
-  (let ((*input* (iter:list-iterator lst)))
-    (exec-input)))
-
-(defun exec-string (s)
-  (let ((*input* (iter:string-iterator s)))
-    (exec-input)))
-
-(defun exec-input ()
-  (iter:process *input* #'exec-item))
-
-(defun comp-input ()
-  (let ((*buffer* nil))
-    (iter:process *input* #'comp-item)
-    (pushd (reverse *buffer*))))
-
-(defun call (code)
-  (util:lgi code)
-  (let ((*code* code))
-    (do ((fn (pop *code*) (pop *code*)))
-        ((null fn))
-      (funcall fn))))
-
-(defun reg (sym fn &optional (cls 'word))
-  (let ((sym (intern (symbol-name sym) (current-package *forge-env*))))
-    (setf (gethash sym (vocabulary *forge-env*)) (make-instance cls :func fn))
-    (setf (gethash fn (func-index *forge-env*)) sym)))
-
-(defun reg1 (sym fn)
-  (reg sym #'(lambda () (pushd (funcall fn (popd))))))
-
-(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 *forge-env*)))
-
-(defun popd ()
-  (pop (stack *forge-env*)))
-
-(defun peekd ()
-  (car (stack *forge-env*)))
-
-(defun next () 
-  (pushd (pop *code*)))
-
-;;;; builtins
-
-(defpackage :sf-builtin
-  (:use :common-lisp)
-  (:local-nicknames (:f :scopes/forge/sf)
-                    (:iter :scopes/util/iter)
-                    (:util :scopes/util))
-  (:export #:add #:mul #:drop #:dup #:swp 
-           #:? #:??
-           #:ptr #:get #:put
-           #:in #:next 
-           #:call #:call-if #:call-while #:val
-           #:<comp #:reg #:regc #:/>))
-
-(in-package :sf-builtin)
-
-;;;; implementation functions
-
-(defun call-if ()
-  (let ((code (f:popd)))
-    (if (f:popd)
-      (f:call code))))
-
-(defun call-while ()
-  (let ((code (f:popd)))
-    (do ((cond (f:popd) (f:popd)))
-        ((not cond))
-      (f:call code))))
-
-;;;; lisp-code word definitions
-
-(f:reg2 'add #'+)
-(f:reg2 'mul #'*)
-
-(f:reg 'dup #'(lambda () (f:pushd (f:peekd))))
-(f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b))))
-(f:reg 'drop #'f:popd)
-
-(f:reg '? #'(lambda () (format t "~a~%" (f:popd))))
-(f:reg '?? #'(lambda () (format t "~a~%" (f:stack f:*forge-env*))))
-
-(f:reg1 'ptr #'util:ptr)
-(f:reg1 'get #'aref)
-(f:reg 'put #'(lambda () (setf (aref (f:popd)) (f:popd))))
-
-(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
-(f:reg 'next #'f:next)
-
-(f:reg 'call #'(lambda () (f:call (popd))))
-(f:reg 'call-if #'call-if)
-(f:reg 'call-while #'call-while)
-(f:reg 'val #'(lambda () (f:pushd (list #'f:next (f:popd)))))
-
-(f:reg '<comp #'f:comp-input)
-
-(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)
-
-;;;; forge-code word definitions
diff --git a/forge/x-forge.lisp b/forge/x-forge.lisp
new file mode 100644
index 0000000..be7ed83
--- /dev/null
+++ b/forge/x-forge.lisp
@@ -0,0 +1,224 @@
+;;;; cl-scopes/forge - may the forge be with you!
+
+;;;; A Forth-like interpreter implemented in Common Lisp.
+
+(defpackage :scopes/forge
+  (:use :common-lisp)
+  (: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
+           #:with-trace))
+
+(defpackage :sf-builtin)
+(defpackage :sf-user)
+
+(in-package :scopes/forge)
+
+(defmacro with-trace (&body body)
+  `(let ((*features* (cons :forge-trace *features*))) ,@body))
+
+;;; iseq: iterable sequence
+
+(defclass iseq ()
+  ((start :reader start :initform (list nil) :initarg :start)
+   (cur :accessor cur)
+   (end :accessor end)))
+
+(defun make-iseq (&optional start)
+  (let* ((start (cons nil start))
+         (seq (make-instance 'iseq :start start)))
+    (setf (cur seq) (setf (end seq) start))
+    seq))
+
+(defun isq-all (seq)
+  (cdr (start seq)))
+
+(defun isq-cur (seq)
+  (car (cur seq)))
+
+(defun isq-end (seq)
+  (car (end seq)))
+
+(defun isq-next (seq)
+  (pop (cur seq))
+  (car (cur seq)))
+
+(defun isq-add (seq v)
+  (setf (cdr (end seq)) (list v))
+  (pop (end seq)))
+
+;;; forge environment
+
+(defclass forge-env ()
+  ((data-stack :initform nil :accessor data-stack)
+   (words :initform (make-hash-table :test #'eq))
+   (comp-words :initform (make-hash-table))
+   (words-rev :initform (make-hash-table))
+   (words-meta :initform (make-hash-table))
+   (packages :initform '(:sf-user :sf-builtin))
+   (current-package :initform :sf-builtin)
+   (ip :initform (make-iseq))
+   (rp) (cp)))
+
+(defun forge-env ()
+  (make-instance 'forge-env))
+
+(defvar *forge-env* (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 comp-words () (slot-value *forge-env* 'comp-words))
+
+(defun register-comp-word (sym fn &key code)
+  (register sym fn :slot 'comp-words :code code))
+
+(defun register (sym fn &key (slot 'words) code)
+  (let* ((w (intern (string sym) (current-package)))
+         (words (slot-value *forge-env* slot)))
+    (setf (gethash w words) fn)
+    (setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
+    (if code
+      (setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
+
+;;; builtins
+
+(defmacro reg (sym &body body)
+  `(register ',sym #'(lambda () ,@body)))
+
+(defun lit () (pushd (isq-next (fip))))
+
+(defun do-reg (&optional (fn #'register))
+  (let* ((name (popd))
+         (code (popd)))
+    (funcall fn name #'(lambda () (call code)) :code code)))
+
+(defun do-quote () 
+  (let ((quoted (read-next)))
+    #+forge-trace (format t " - do-quote: ~a" quoted)
+    (comp-item #'lit) (comp-item quoted)))
+
+(defun do-comp () 
+  (let* ((sym (read-next))
+         (w (get-word sym)))
+    ;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
+    (comp-item (gethash w (comp-words)))))
+
+(defun setup-builtins ()
+  (register 'lit #'lit)
+  (register 'reg #'do-reg)
+
+  (reg + (pushd (+ (popd) (popd))))
+  (reg * (pushd (* (popd) (popd))))
+  (reg dup (pushd (car (dstack))))
+  (reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
+  (reg ? (format t "~a~%" (popd)))
+  (reg ?? (format t "~a~%" (dstack)))
+  (reg get (pushd (cadr (popd))))
+  (reg set (setf (cadr (popd)) (popd)))
+  (reg wrap (pushd (list #'lit (popd))))
+  (reg defer (comp-item (isq-next (fip))))
+  (reg regc (do-reg #'register-comp-word))
+
+  (register-comp-word 'quote #'do-quote)
+  (register-comp-word 'comp #'do-comp)
+
+  (activate-package :sf-user))
+
+;;; trace functionality
+
+(defun decompile-item (item)
+  (or (gethash item (slot-value *forge-env* 'words-rev))
+      (typecase item
+        (cons (decompile item))
+        (t item))))
+
+(defun decompile (code)
+  (mapcar #'decompile-item code))
+
+(defun trace-call (code)
+  (format t "~%call: ~a" (decompile code)))
+
+;;; compiler, interpreter
+
+(defun exec-str (s)
+  (exec (read-from-string 
+             (concatenate 'string "(" s ")"))))
+
+(defun repl ()
+  (do ((input (read-line) (read-line))) 
+      ((string= input "q") (dstack))
+    (exec-str input)))
+
+(defun exec (code)
+  (call (comp code)))
+
+(defun call (code)
+  #+forge-trace (trace-call code)
+  (let ((old-ip (fip))
+        (ip (make-iseq code)))
+    (setf (slot-value *forge-env* 'ip) ip)
+    (do ((item (isq-next ip) (isq-next ip)))
+        ((null item))
+      (funcall item))
+    (setf (slot-value *forge-env* 'ip) old-ip)
+    #+forge-trace (format t "~% - stack: ~A" (dstack))
+    (dstack)))
+
+(defun comp (slist)
+  #+forge-trace (format t "~%comp: ~a" slist)
+  (let ((cp (make-iseq))
+        (inp (make-iseq slist)))
+    (setf (slot-value *forge-env* 'cp) cp)
+    (setf (slot-value *forge-env* 'rp) inp)
+    (do ((item (isq-next inp) (isq-next inp)))
+        ((null item))
+      (typecase item
+        (symbol (comp-symbol item))
+        (cons (let ((sub (comp item)))
+                (setf (slot-value *forge-env* 'cp) cp)
+                (setf (slot-value *forge-env* 'rp) inp)
+                (comp-item #'lit)
+                (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 "~%comp-symbol ~a ~a ~a" sym w comp-fn)
+    (if comp-fn
+      (funcall comp-fn)
+      (comp-item (gethash w (words))))))
+
+(defun get-word (sym)
+  (let ((name (string sym)))
+    (dolist (p (packages))
+      (let ((w (find-symbol name p)))
+        (if w 
+          (return-from get-word w))))))
+
+;;; internal definitions / forge-env pseudo-methods
+
+(defun popd () (pop (data-stack *forge-env*)))
+
+(defun pushd (v) (push v (data-stack *forge-env*)))
+
+(defun fcp () (slot-value *forge-env* 'cp))
+
+(defun comp-item (item) (isq-add (fcp) item))
+
+(defun fip () (slot-value *forge-env* 'ip))
+
+(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
+
+(defun packages () (slot-value *forge-env* 'packages))
+
+(defun current-package () (slot-value *forge-env* 'current-package))
+