From dff1de06a83de68c19a8f353fc7bae76251f8ddb Mon Sep 17 00:00:00 2001 From: Helmut Merz Date: Mon, 22 Apr 2024 15:02:36 +0200 Subject: [PATCH] define words with 'def' working --- forge/forge.lisp | 12 +++++++++++- test/test-forge.lisp | 12 +++++++++--- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/forge/forge.lisp b/forge/forge.lisp index cdfe523..31886b8 100644 --- a/forge/forge.lisp +++ b/forge/forge.lisp @@ -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 diff --git a/test/test-forge.lisp b/test/test-forge.lisp index 2676432..71f2414 100644 --- a/test/test-forge.lisp +++ b/test/test-forge.lisp @@ -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))