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

forge: reg basically working

Browse source
This commit is contained in:
Helmut Merz 2024-05-28 09:39:29 +02:00
parent 527f5b4884
commit 192c6c0fb9
5 changed files with 35 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
forge/forge.lisp
View file

@ -95,6 +95,18 @@
(register 'lit #'lit) (register 'lit #'lit)
(register 'reg
#'(lambda ()
(let* ((name (popd))
(code (popd)))
(format t "~%~a ~a" name code)
(register name #'(lambda () (call code))))))
(register-comp-word 'quote
#'(lambda ()
(let ((w (read-next)))
(comp-item #'lit) (comp-item w))))
(register-comp-word 'def (register-comp-word 'def
#'(lambda () #'(lambda ()
(let* ((name (read-next)) (let* ((name (read-next))
@ -119,25 +131,33 @@
(defun call (code) (defun call (code)
(let ((ip (make-iseq code))) (let ((ip (make-iseq code)))
(setf (slot-value *forge-env* 'ip) ip) (setf (slot-value *forge-env* 'ip) ip)
(print (isq-all ip))
(do ((item (isq-next ip) (isq-next ip))) (do ((item (isq-next ip) (isq-next ip)))
((null item)) ((null item))
(funcall item)))) (funcall item))))
(defun comp (slist) (defun comp (slist)
(setf (slot-value *forge-env* 'cp) (make-iseq)) (let ((cp (make-iseq)))
(setf (slot-value *forge-env* 'cp) cp)
(let ((inp (make-iseq slist))) (let ((inp (make-iseq slist)))
(setf (slot-value *forge-env* 'rp) inp) (setf (slot-value *forge-env* 'rp) inp)
(do ((item (isq-next inp) (isq-next inp))) (do ((item (isq-next inp) (isq-next inp)))
((null item)) ((null item))
(print item)
(typecase item (typecase item
(symbol (comp-symbol item)) (symbol (comp-symbol item))
(cons (comp-item #'lit) (comp-item (comp item))) (cons (comp-item #'lit)
(t (comp-item #'lit) (comp-item item))))) (let ((sub (comp item)))
(setf (slot-value *forge-env* 'cp) cp)
(setf (slot-value *forge-env* 'rp) inp)
(comp-item sub)))
(t (comp-item #'lit) (comp-item item))))))
(isq-all (fcp))) (isq-all (fcp)))
(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 "~%~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))))))

2
scopes-forge.asd
View file

@ -16,4 +16,4 @@
(defsystem :scopes-forge/test (defsystem :scopes-forge/test
:depends-on (:scopes-forge) :depends-on (:scopes-forge)
:components ((:file "test/test-forge")) :components ((:file "test/test-forge"))
:perform (test-op (o c) (funcall #'scopes/test-forge:run))) :perform (test-op (o c) (symbol-call :scopes/test-forge :run)))

4
scopes.asd
View file

@ -24,5 +24,5 @@
:components ((:file "test/test-storage") :components ((:file "test/test-storage")
(:file "test/test-forge")) (:file "test/test-forge"))
:perform (test-op (o c) :perform (test-op (o c)
(funcall #'scopes/test-storage:run-all) (symbol-call :scopes/test-storage :run-all)
(funcall #'scopes/test-forge:run))) (symbol-call :scopes/test-forge :run)))

1
steps/steps.lisp
View file

@ -5,3 +5,4 @@
(in-package :scopes/steps) (in-package :scopes/steps)
(defclass process ())

3
test/test-forge.lisp
View file

@ -33,6 +33,7 @@
(== (car (forge:dstack)) 6)) (== (car (forge:dstack)) 6))
(deftest test-def () (deftest test-def ()
(forge:exec-str "def square (dup *)") ;(forge:exec-str "def square (dup *)")
(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))