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

forge: minor refactoring - use + and * for add and mul, ...

Browse source
This commit is contained in:
Helmut Merz 2024-05-26 13:56:40 +02:00
parent 98e9e59017
commit 3a764bc9f8
2 changed files with 19 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
forge/forge.lisp
View file

@ -1,4 +1,4 @@
;;; cl-scopes/forge - may the forge be with you! ;;;; cl-scopes/forge - may the forge be with you!
;;;; A Forth-like interpreter implemented in Common Lisp. ;;;; A Forth-like interpreter implemented in Common Lisp.
@ -72,11 +72,10 @@
(defun comp-words () (slot-value *forge-env* 'comp-words)) (defun comp-words () (slot-value *forge-env* 'comp-words))
(defun register-comp-word (sym fn) (defun register-comp-word (sym fn)
(register sym fn :slot 'comp-words)) (register sym fn 'comp-words))
(defun register (sym fn &key package (slot 'words)) (defun register (sym fn &optional (slot 'words))
(let* ((p (or package (current-package))) (let* ((w (intern (string sym) (current-package)))
(w (intern (string sym) p))
(words (slot-value *forge-env* slot))) (words (slot-value *forge-env* slot)))
(setf (gethash w words) fn))) (setf (gethash w words) fn)))
@ -85,21 +84,21 @@
(defmacro reg (sym &body body) (defmacro reg (sym &body body)
`(register ',sym #'(lambda () ,@body))) `(register ',sym #'(lambda () ,@body)))
(defvar lit #'(lambda () (pushd (isq-next (fip))))) (defun lit () (pushd (isq-next (fip))))
(defun setup-builtins () (defun setup-builtins ()
(reg add (pushd (+ (popd) (popd)))) (reg + (pushd (+ (popd) (popd))))
(reg mul (pushd (* (popd) (popd)))) (reg * (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack)))) (reg dup (pushd (car (dstack))))
(register 'lit lit) (register 'lit #'lit)
(register-comp-word 'def (register-comp-word 'def
#'(lambda () #'(lambda ()
(let* ((name (isq-next (frp))) (let* ((name (read-next))
(code (comp (isq-next (frp))))) (code (comp (read-next))))
(register name #'(lambda () (call code)))))) (register name #'(lambda () (call code))))))
(activate-package :sf-user)) (activate-package :sf-user))
@ -132,8 +131,8 @@
((null item)) ((null 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) (comp-item (comp item)))
(t (comp-item lit) (comp-item item))))) (t (comp-item #'lit) (comp-item item)))))
(isq-all (fcp))) (isq-all (fcp)))
(defun comp-symbol (sym) (defun comp-symbol (sym)
@ -143,9 +142,6 @@
(funcall comp-fn) (funcall comp-fn)
(comp-item (gethash w (words)))))) (comp-item (gethash w (words))))))
(defun comp-item (item)
(isq-add (fcp) item))
(defun get-word (sym) (defun get-word (sym)
(let ((name (string sym))) (let ((name (string sym)))
(dolist (p (packages)) (dolist (p (packages))
@ -159,12 +155,14 @@
(defun pushd (v) (push v (data-stack *forge-env*))) (defun pushd (v) (push v (data-stack *forge-env*)))
(defun frp () (slot-value *forge-env* 'rp))
(defun fcp () (slot-value *forge-env* 'cp)) (defun fcp () (slot-value *forge-env* 'cp))
(defun comp-item (item) (isq-add (fcp) item))
(defun fip () (slot-value *forge-env* 'ip)) (defun fip () (slot-value *forge-env* 'ip))
(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
(defun packages () (slot-value *forge-env* 'packages)) (defun packages () (slot-value *forge-env* 'packages))
(defun current-package () (slot-value *forge-env* 'current-package)) (defun current-package () (slot-value *forge-env* 'current-package))

6
test/test-forge.lisp
View file

@ -1,4 +1,4 @@
;;; cl-scopes/test/test-forge ;;;; cl-scopes/test/test-forge
;;;; testing facility for scopes/forge ;;;; testing facility for scopes/forge
@ -29,10 +29,10 @@
(== (forge:isq-end seq) 2))) (== (forge:isq-end seq) 2)))
(deftest test-exec () (deftest test-exec ()
(forge:exec-str "4 2 add") (forge:exec-str "4 2 +")
(== (car (forge:dstack)) 6)) (== (car (forge:dstack)) 6))
(deftest test-def () (deftest test-def ()
(forge:exec-str "def square (dup mul)") (forge:exec-str "def square (dup *)")
(forge:exec-str "7 square") (forge:exec-str "7 square")
(== (car (forge:dstack)) 49)) (== (car (forge:dstack)) 49))