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

provide var definition with get and put operations

Browse source
This commit is contained in:
Helmut Merz 2024-04-28 14:56:46 +02:00
parent 6e40672f10
commit df88bec20a
2 changed files with 31 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
forge/forge.lisp
View file

@ -59,21 +59,35 @@
(reg-b "??" #'(lambda (fe) (format t "~a~%" (data-stack fe)))) (reg-b "??" #'(lambda (fe) (format t "~a~%" (data-stack fe))))
(reg-b "def" #'(lambda (fe) (reg-b "def" #'(lambda (fe)
(let ((voc (car(vocabulary fe))) (let ((name (popd fe))
(name (popd fe))
(code (popd fe))) (code (popd fe)))
(register voc name #'(lambda (fe) (exec fe code)))))) (register (voc fe) name #'(lambda (fe) (exec fe code))))))
(reg-b "const" #'(lambda (fe) (reg-b "const" #'(lambda (fe)
(let ((name (popd fe)) (let ((name (popd fe))
(value (popd fe))) (value (popd fe)))
(register (car(vocabulary fe)) name #'(lambda (fe) (pushd fe value)))))) (register (voc fe) name #'(lambda (fe) (pushd fe value))))))
(reg-b "var" #'(lambda (fe)
(let ((name (popd fe))
(var (list (popd fe))))
(register (voc fe) name #'(lambda (fe)
(pushd fe #'(lambda (fn)
(funcall fn var))))))))
(reg-b "get" #'(lambda (fe)
(funcall (popd fe) #'(lambda (x) (pushd fe (car x))))))
(reg-b "put" #'(lambda (fe)
(let ((fn (popd fe))
(vl (popd fe)))
(funcall fn #'(lambda (x) (setf (car x) vl))))))
; internal definitions ; internal definitions
(defun popd (fe) (defun voc (fe) (car (vocabulary fe)))
(pop (data-stack! fe)))
(defun pushd (fe v) (defun popd (fe) (pop (data-stack! fe)))
(push v (data-stack! fe)))
(defun pushd (fe v) (push v (data-stack! fe)))

9
test/test-forge.lisp
View file

@ -18,6 +18,7 @@
(test-def tst fe) (test-def tst fe)
(test-exec-str tst fe) (test-exec-str tst fe)
(test-const tst fe) (test-const tst fe)
(test-var tst fe)
(sct:result tst))) (sct:result tst)))
(defun test-exec (tst fe) (defun test-exec (tst fe)
@ -37,3 +38,11 @@
(scf:exec-str fe "17 \"c1\" const") (scf:exec-str fe "17 \"c1\" const")
(scf:exec-str fe "c1 square") (scf:exec-str fe "c1 square")
(sct:assert-eq tst (car (scf:data-stack fe)) 289)) (sct:assert-eq tst (car (scf:data-stack fe)) 289))
(defun test-var (tst fe)
(scf:exec fe '(24 "v1" var))
(scf:exec fe '(v1 get 2 *))
(sct:assert-eq tst (car (scf:data-stack fe)) 48)
(scf:exec fe '(5 v1 put))
(scf:exec fe '(v1 get 2 *))
(sct:assert-eq tst (car (scf:data-stack fe)) 10))