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.
@ -72,11 +72,10 @@
(defun comp-words () (slot-value *forge-env* 'comp-words))
(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))
(let* ((p (or package (current-package)))
(w (intern (string sym) p))
(defun register (sym fn &optional (slot 'words))
(let* ((w (intern (string sym) (current-package)))
(words (slot-value *forge-env* slot)))
(setf (gethash w words) fn)))
@ -85,21 +84,21 @@
(defmacro reg (sym &body body)
`(register ',sym #'(lambda () ,@body)))
(defvar lit #'(lambda () (pushd (isq-next (fip)))))
(defun lit () (pushd (isq-next (fip))))
(defun setup-builtins ()
(reg add (pushd (+ (popd) (popd))))
(reg mul (pushd (* (popd) (popd))))
(reg + (pushd (+ (popd) (popd))))
(reg * (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack))))
(register 'lit lit)
(register 'lit #'lit)
(register-comp-word 'def
#'(lambda ()
(let* ((name (isq-next (frp)))
(code (comp (isq-next (frp)))))
(let* ((name (read-next))
(code (comp (read-next))))
(register name #'(lambda () (call code))))))
(activate-package :sf-user))
@ -132,8 +131,8 @@
((null item))
(typecase item
(symbol (comp-symbol item))
(cons (comp-item lit) (comp-item (comp item)))
(t (comp-item lit) (comp-item item)))))
(cons (comp-item #'lit) (comp-item (comp item)))
(t (comp-item #'lit) (comp-item item)))))
(isq-all (fcp)))
(defun comp-symbol (sym)
@ -143,9 +142,6 @@
(funcall comp-fn)
(comp-item (gethash w (words))))))
(defun comp-item (item)
(isq-add (fcp) item))
(defun get-word (sym)
(let ((name (string sym)))
(dolist (p (packages))
@ -159,12 +155,14 @@
(defun pushd (v) (push v (data-stack *forge-env*)))
(defun frp () (slot-value *forge-env* 'rp))
(defun fcp () (slot-value *forge-env* 'cp))
(defun comp-item (item) (isq-add (fcp) item))
(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 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
@ -29,10 +29,10 @@
(== (forge:isq-end seq) 2)))
(deftest test-exec ()
(forge:exec-str "4 2 add")
(forge:exec-str "4 2 +")
(== (car (forge:dstack)) 6))
(deftest test-def ()
(forge:exec-str "def square (dup mul)")
(forge:exec-str "def square (dup *)")
(forge:exec-str "7 square")
(== (car (forge:dstack)) 49))