cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

work in progress: const as forge-word defined with reg and regc

Browse source
This commit is contained in:
Helmut Merz 2024-05-28 16:10:07 +02:00
parent 18203bd833
commit 52f9f7e3ed
2 changed files with 27 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
forge/forge.lisp
View file

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

7
test/test-forge.lisp
View file

@ -19,6 +19,7 @@
(test-exec) (test-exec)
;(format t "~%data-stack ~a" (dstack)) ;(format t "~%data-stack ~a" (dstack))
(test-def) (test-def)
(test-const)
(t:show-result))) (t:show-result)))
(deftest test-iseq () (deftest test-iseq ()
@ -37,3 +38,9 @@
(forge:exec-str "(dup *) quote square reg") (forge:exec-str "(dup *) quote square reg")
(forge:exec-str "7 square") (forge:exec-str "7 square")
(== (car (forge:dstack)) 49)) (== (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 "eleven square")
(== (car (forge:dstack)) 121))