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

forge improvements: use macro for registration, initialize builtins via explicit init-forge-env

Browse source
This commit is contained in:
Helmut Merz 2024-05-24 19:52:58 +02:00
parent 7c9434960e
commit 43a0b0f9d8
2 changed files with 20 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
forge/forge.lisp
View file

@ -4,7 +4,7 @@
(defpackage :scopes/forge (defpackage :scopes/forge
(:use :common-lisp) (:use :common-lisp)
(:export #:*forge-env* (:export #:*forge-env* #:init-forge-env
#:forge-env #:dstack #:exec #:exec-str #:repl #:forge-env #:dstack #:exec #:exec-str #:repl
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add)) #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
@ -80,18 +80,21 @@
(let ((p (or p (current-package)))) (let ((p (or p (current-package))))
(set-word (intern (string sym) p) fn))) (set-word (intern (string sym) p) fn)))
(defmacro reg (sym &body body)
`(register ',sym #'(lambda () ,@body) :sf-builtin))
;;; builtins ;;; builtins
(defun reg-b (sym fn)
(register sym fn :sf-builtin))
(reg-b 'add #'(lambda () (pushd (+ (popd) (popd)))))
(reg-b 'mul #'(lambda () (pushd (* (popd) (popd)))))
(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)
(defun init-forge-env ()
(reg add (pushd (+ (popd) (popd))))
(reg mul (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack))))
(register 'lit lit :sf-builtin)
(register-comp-word 'def (register-comp-word 'def
#'(lambda () #'(lambda ()
@ -99,6 +102,7 @@
(code (comp (isq-next (frp))))) (code (comp (isq-next (frp)))))
(register name #'(lambda () (call code))))) (register name #'(lambda () (call code)))))
:sf-builtin) :sf-builtin)
)
;;; compiler, interpreter ;;; compiler, interpreter
@ -168,3 +172,7 @@
(defun current-package () (slot-value *forge-env* 'current-package)) (defun current-package () (slot-value *forge-env* 'current-package))
(defun activate-package(p)
(let ((old (current-package)))
(setf (slot-value *forge-env* 'current-package) p)
old))

1
test/test-forge.lisp
View file

@ -13,6 +13,7 @@
(defun run () (defun run ()
(let ((t:*test-suite* (t:test-suite "forge"))) (let ((t:*test-suite* (t:test-suite "forge")))
(forge:init-forge-env)
(test-iseq) (test-iseq)
(test-exec) (test-exec)
;(format t "~%data-stack ~a" (dstack)) ;(format t "~%data-stack ~a" (dstack))