diff --git a/forge/forge.lisp b/forge/forge.lisp index a224f8e..64efe69 100644 --- a/forge/forge.lisp +++ b/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 - #'(lambda () - (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 'quote #'do-quote) + (register-comp-word 'comp #'do-comp) (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)))))) diff --git a/test/test-forge.lisp b/test/test-forge.lisp index 1d38957..b9fd889 100644 --- a/test/test-forge.lisp +++ b/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 "(11) const eleven") + (forge:exec-str "(defer wrap comp quote defer reg) quote const regc") + (forge:exec-str "11 const eleven") (forge:exec-str "eleven square") (== (car (forge:dstack)) 121))