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

forge, new implementation: basically working

Browse source
This commit is contained in:
Helmut Merz 2024-05-24 17:34:17 +02:00
parent 944b3402e5
commit 7c9434960e
2 changed files with 35 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
forge/forge.lisp
View file

@ -64,33 +64,41 @@
(defun dstack() (defun dstack()
(data-stack *forge-env*)) (data-stack *forge-env*))
(defun define-comp-word (sym fn) (defun words () (slot-value *forge-env* 'words))
(setf (gethash sym (slot-value *forge-env* 'comp-words)) fn))
(defun register (p sym fn) (defun set-word (w fn) (setf (gethash w (words)) fn))
(let ((w (intern (string sym) p)))
(setf (gethash w (slot-value *forge-env* 'words)) fn))) (defun comp-words () (slot-value *forge-env* 'comp-words))
(defun set-comp-word (w fn) (setf (gethash w (comp-words)) fn))
(defun register-comp-word (sym fn &optional p)
(let ((p (or p (current-package))))
(set-comp-word (intern (string sym) p) fn)))
(defun register (sym fn &optional p)
(let ((p (or p (current-package))))
(set-word (intern (string sym) p) fn)))
;;; builtins ;;; builtins
(defun reg-b (sym fn) (defun reg-b (sym fn)
(register :sf-builtin sym fn)) (register sym fn :sf-builtin))
(reg-b 'add #'(lambda () (pushd (+ (popd) (popd))))) (reg-b 'add #'(lambda () (pushd (+ (popd) (popd)))))
(reg-b 'mul #'(lambda () (pushd (* (popd) (popd)))))
(reg-b 'dup #'(lambda () (pushd (car (dstack))))) (reg-b 'dup #'(lambda () (pushd (car (dstack)))))
(defvar lit #'(lambda () (pushd (isq-next (fip))))) (defvar lit #'(lambda () (pushd (isq-next (fip)))))
(reg-b 'lit lit) (reg-b 'lit lit)
(define-comp-word 'def (register-comp-word 'def
#'(lambda () #'(lambda ()
(let* ((name (isq-next (frp))) (let* ((name (isq-next (frp)))
(code (isq-next (frp)))) (code (comp (isq-next (frp)))))
(print name) (register name #'(lambda () (call code)))))
(print code) :sf-builtin)
;(eval `(defvar ,name (comp code)))
)))
;;; compiler, interpreter ;;; compiler, interpreter
@ -126,26 +134,25 @@
(defun comp-symbol (sym) (defun comp-symbol (sym)
(let* ((w (get-word sym)) (let* ((w (get-word sym))
(comp-fn (get-comp-word w))) (comp-fn (get-comp-fn w)))
(if comp-fn (if comp-fn
(funcall comp-fn) (funcall comp-fn)
(comp-item (gethash w (slot-value *forge-env* 'words)))))) (comp-item (gethash w (words))))))
(defun comp-item (item) (defun comp-item (item)
(isq-add (fcp) item)) (isq-add (fcp) item))
(defun get-word (sym) (defun get-word (sym)
(let ((name (string sym))) (let ((name (string sym)))
(dolist (p (slot-value *forge-env* 'packages)) (dolist (p (packages))
(let ((w (find-symbol name p))) (let ((w (find-symbol name p)))
(if w (if w
(return-from get-word w)))) (return-from get-word w))))))
(intern name (slot-value *forge-env* 'current-package))))
(defun get-comp-word (w) (defun get-comp-fn (w)
(gethash w (slot-value *forge-env* 'comp-words))) (gethash w (comp-words)))
;;; internal definitions ;;; internal definitions / forge-env pseudo-methods
(defun popd () (pop (data-stack *forge-env*))) (defun popd () (pop (data-stack *forge-env*)))
@ -156,3 +163,8 @@
(defun fcp () (slot-value *forge-env* 'cp)) (defun fcp () (slot-value *forge-env* 'cp))
(defun fip () (slot-value *forge-env* 'ip)) (defun fip () (slot-value *forge-env* 'ip))
(defun packages () (slot-value *forge-env* 'packages))
(defun current-package () (slot-value *forge-env* 'current-package))

6
test/test-forge.lisp
View file

@ -31,6 +31,6 @@
(== (car (forge:dstack)) 6)) (== (car (forge:dstack)) 6))
(deftest test-def () (deftest test-def ()
(forge:exec-str "def square (dup *)")) (forge:exec-str "def square (dup mul)")
;(forge:exec-str "7 square") (forge:exec-str "7 square")
;(== (car (forge:dstack)) 49)) (== (car (forge:dstack)) 49))