forge, new implementation: basically working

forge/forge.lisp

@@ -64,33 +64,41 @@
 (defun dstack()
   (data-stack *forge-env*))
 
-(defun define-comp-word (sym fn)
-  (setf (gethash sym (slot-value *forge-env* 'comp-words)) fn))
+(defun words () (slot-value *forge-env* 'words))
 
-(defun register (p sym fn)
-  (let ((w (intern (string sym) p)))
-    (setf (gethash w (slot-value *forge-env* 'words)) fn)))
+(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 &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)))
 
 ;;; builtins
 
 (defun reg-b (sym fn)
-  (register :sf-builtin sym fn))
+  (register sym fn :sf-builtin))
 
 (reg-b 'add #'(lambda () (pushd (+ (popd) (popd)))))
+(reg-b 'mul #'(lambda () (pushd (* (popd) (popd)))))
 
 (reg-b 'dup #'(lambda () (pushd (car (dstack)))))
 
 (defvar lit #'(lambda () (pushd (isq-next (fip)))))
 (reg-b 'lit lit)
 
-(define-comp-word 'def
+(register-comp-word 'def
   #'(lambda () 
       (let* ((name (isq-next (frp)))
-             (code (isq-next (frp))))
-        (print name)
-        (print code)
-        ;(eval `(defvar ,name (comp code)))
-        )))
+             (code (comp (isq-next (frp)))))
+        (register name #'(lambda () (call code)))))
+  :sf-builtin)
 
 ;;; compiler, interpreter
 
@@ -126,26 +134,25 @@
 
 (defun comp-symbol (sym)
   (let* ((w (get-word sym))
-         (comp-fn (get-comp-word w)))
+         (comp-fn (get-comp-fn w)))
     (if comp-fn
       (funcall comp-fn)
-      (comp-item (gethash w (slot-value *forge-env* 'words))))))
+      (comp-item (gethash w (words))))))
 
 (defun comp-item (item)
   (isq-add (fcp) item))
 
 (defun get-word (sym)
   (let ((name (string sym)))
-    (dolist (p (slot-value *forge-env* 'packages))
+    (dolist (p (packages))
       (let ((w (find-symbol name p)))
         (if w 
-          (return-from get-word w))))
-    (intern name (slot-value *forge-env* 'current-package))))
+          (return-from get-word w))))))
 
-(defun get-comp-word (w)
-  (gethash w (slot-value *forge-env* 'comp-words)))
+(defun get-comp-fn (w)
+  (gethash w (comp-words)))
 
-;;; internal definitions
+;;; internal definitions / forge-env pseudo-methods
 
 (defun popd () (pop (data-stack *forge-env*)))
 
@@ -156,3 +163,8 @@
 (defun fcp () (slot-value *forge-env* 'cp))
 
 (defun fip () (slot-value *forge-env* 'ip))
+
+(defun packages () (slot-value *forge-env* 'packages))
+
+(defun current-package () (slot-value *forge-env* 'current-package))
+

test/test-forge.lisp

@@ -31,6 +31,6 @@
   (== (car (forge:dstack)) 6))
 
 (deftest test-def ()
-  (forge:exec-str "def square (dup *)"))
-  ;(forge:exec-str "7 square")
-  ;(== (car (forge:dstack)) 49))
+  (forge:exec-str "def square (dup mul)")
+  (forge:exec-str "7 square")
+  (== (car (forge:dstack)) 49))