forge: const basically working; provide with-trace macro

forge/forge.lisp

@@ -6,13 +6,17 @@
   (: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))
+           #: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 ()
@@ -85,14 +89,27 @@
   `(register ',sym #'(lambda () ,@body)))
 
 (defun lit () (pushd (isq-next (fip))))
+(defun wrap () (pushd (list #'lit (popd))))
 (defun defer () (comp-item (isq-next (fip))))
-(defun do-pop () (comp-item #'lit) (comp-item (popd)))
 
 (defun do-reg ()
   (let* ((name (popd))
          (code (popd)))
     (register name #'(lambda () (call code)))))
 
+(defun do-regc ()
+  (let* ((name (popd))
+         (code (popd)))
+    (register-comp-word name #'(lambda () (call code)))))
+
+(defun do-quote () (comp-item #'lit) (comp-item (read-next)))
+
+(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 ()
 
   (reg + (pushd (+ (popd) (popd))))
@@ -102,24 +119,13 @@
   (reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
 
   (register 'lit #'lit)
+  (register 'wrap #'wrap)
   (register 'defer #'defer)
-  (register 'pop #'do-pop)
   (register 'reg #'do-reg)
+  (register 'regc #'do-regc)
 
-  (register 'regc
+  (register-comp-word 'quote #'do-quote)
-    #'(lambda ()
+  (register-comp-word 'comp #'do-comp)
-        (let* ((name (popd))
-               (code (popd)))
-          (register-comp-word name #'(lambda () (call code))))))
-
-  (register-comp-word 'quote
-    #'(lambda () (comp-item #'lit) (comp-item (read-next))))
-
-  (register-comp-word 'comp
-    #'(lambda () (let* ((sym (read-next))
-                        (w (get-word sym)))
-                   (format t "~%rcw: ~a ~a ~a" sym w (gethash w (comp-words)))
-                    (comp-item (gethash w (comp-words))))))
 
   (register-comp-word 'def
     #'(lambda () 
@@ -143,7 +149,7 @@
   (call (comp code)))
 
 (defun call (code)
-  (print code)
+  #+forge-trace (print code)
   (let ((old-ip (fip))
         (ip (make-iseq code)))
     (setf (slot-value *forge-env* 'ip) ip)
@@ -153,7 +159,7 @@
     (setf (slot-value *forge-env* 'ip) old-ip)))
 
 (defun comp (slist)
-  (print slist)
+  #+forge-trace (print slist)
   (let ((cp (make-iseq))
         (inp (make-iseq slist)))
     (setf (slot-value *forge-env* 'cp) cp)
@@ -173,7 +179,7 @@
 (defun comp-symbol (sym)
   (let* ((w (get-word sym))
          (comp-fn (gethash w (comp-words))))
-    (format t "~%csym: ~a ~a ~a" sym w comp-fn)
+    ;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
     (if comp-fn
       (funcall comp-fn)
       (comp-item (gethash w (words))))))

test/test-forge.lisp

@@ -40,7 +40,7 @@
   (== (car (forge:dstack)) 49))
 
 (deftest test-const ()
-  (forge:exec-str "(comp quote defer reg) quote const regc")
+  (forge:exec-str "(defer wrap comp quote defer reg) quote const regc")
-  (forge:exec-str "(11) const eleven")
+  (forge:exec-str "11 const eleven")
   (forge:exec-str "eleven square")
   (== (car (forge:dstack)) 121))