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

define words with 'def' working

Browse source
This commit is contained in:
Helmut Merz 2024-04-22 15:02:36 +02:00
parent 3cfb89d9fd
commit dff1de06a8
2 changed files with 20 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
forge/forge.lisp
View file

@ -27,7 +27,8 @@
(pushd fe x))))
(defun register (voc key fn)
(setf (gethash (string-downcase (symbol-name key)) voc) fn))
(let ((k (if (symbolp key) (symbol-name key) key)))
(setf (gethash (string-downcase k) voc) fn)))
(defun find-word (vocab key)
(let ((k (string-downcase (symbol-name key))) (result nil))
@ -40,6 +41,15 @@
(defun reg-b (key fn) (register *builtins* key fn))
(reg-b 'add #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe)))))
(reg-b 'mul #'(lambda (fe) (pushd fe (* (popd fe) (popd fe)))))
(reg-b 'dup #'(lambda (fe) (pushd fe (car (data-stack fe)))))
(reg-b 'def #'(lambda (fe)
(let ((voc (car(vocabulary fe)))
(name (popd fe))
(code (popd fe)))
(register voc name #'(lambda (fe) (exec fe code))))))
; internal definitions

12
test/test-forge.lisp
View file

@ -14,10 +14,16 @@
(let ((fe (scf:forge-env))
(tst (sct:test-suite)))
(test-exec tst fe)
;(format t "~%fe ~a" fe)
;(format t "~%data-stack ~a" (data-stack fe))
(test-def tst fe)
(sct:result tst)))
(defun test-exec (tst fe)
(scf:exec fe '(4 2 add))
(sct:assert-eq tst (car (scf:data-stack fe)) 6))
(scf:exec fe '(4 2 add))
(sct:assert-eq tst (car (scf:data-stack fe)) 6))
(defun test-def (tst fe)
(scf:exec fe '((dup mul) "square" def))
(scf:exec fe '(7 square))
(sct:assert-eq tst (car (scf:data-stack fe)) 49))