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

add 'scratch' for interactive tests; strings as words, new vocabulary for user-defined words

Browse source
This commit is contained in:
Helmut Merz 2024-04-26 09:31:21 +02:00
parent d3057ff9d7
commit a16f4c2417
3 changed files with 17 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
forge/forge.lisp
View file

@ -18,7 +18,9 @@
:accessor vocabulary))) :accessor vocabulary)))
(defun forge-env () (defun forge-env ()
(make-instance 'forge-env)) (let ((fe (make-instance 'forge-env)))
(push (make-hash-table :test 'equalp) (vocabulary fe))
fe))
(defun exec-str (fe s) (defun exec-str (fe s)
(exec fe (read-from-string (exec fe (read-from-string
@ -44,12 +46,12 @@
(defun reg-b (key fn) (register *builtins* key fn)) (defun reg-b (key fn) (register *builtins* key fn))
(reg-b 'add #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe))))) (reg-b "+" #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe)))))
(reg-b 'mul #'(lambda (fe) (pushd fe (* (popd fe) (popd fe))))) (reg-b "*" #'(lambda (fe) (pushd fe (* (popd fe) (popd fe)))))
(reg-b 'dup #'(lambda (fe) (pushd fe (car (data-stack fe))))) (reg-b "dup" #'(lambda (fe) (pushd fe (car (data-stack fe)))))
(reg-b 'def #'(lambda (fe) (reg-b "def" #'(lambda (fe)
(let ((voc (car(vocabulary fe))) (let ((voc (car(vocabulary fe)))
(name (popd fe)) (name (popd fe))
(code (popd fe))) (code (popd fe)))

8
scratch.lisp Normal file
View file

@ -0,0 +1,8 @@
(defun classes ()
(let ((r nil))
(maphash #'(lambda (k v)
(setf r (cons k r))) si:*class-name-hash-table*)
(sort r #'(lambda (x y)
(string<= (package-name (symbol-package x))
(package-name (symbol-package y)))))))

4
test/test-forge.lisp
View file

@ -20,11 +20,11 @@
(sct:result tst))) (sct:result tst)))
(defun test-exec (tst fe) (defun test-exec (tst fe)
(scf:exec fe '(4 2 add)) (scf:exec fe '(4 2 +))
(sct:assert-eq tst (car (scf:data-stack fe)) 6)) (sct:assert-eq tst (car (scf:data-stack fe)) 6))
(defun test-def (tst fe) (defun test-def (tst fe)
(scf:exec fe '((dup mul) "square" def)) (scf:exec fe '((dup *) "square" def))
(scf:exec fe '(7 square)) (scf:exec fe '(7 square))
(sct:assert-eq tst (car (scf:data-stack fe)) 49)) (sct:assert-eq tst (car (scf:data-stack fe)) 49))