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

forge: setup, register: more improvements, refactoring, simplification

Browse source
This commit is contained in:
Helmut Merz 2024-05-25 08:49:13 +02:00
parent 43a0b0f9d8
commit 98e9e59017
2 changed files with 31 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

63
forge/forge.lisp
View file

@ -4,7 +4,7 @@
(defpackage :scopes/forge
(:use :common-lisp)
(:export #:*forge-env* #:init-forge-env
(:export #:*forge-env* #:setup-builtins #:activate-package
#:forge-env #:dstack #:exec #:exec-str #:repl
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
@ -50,59 +50,59 @@
(words :initform (make-hash-table))
(comp-words :initform (make-hash-table))
(packages :initform '(:sf-user :sf-builtin))
(current-package :initform :sf-user)
(current-package :initform :sf-builtin)
(rp :initform (make-iseq))
(cp :initform (make-iseq))
(ip :initform (make-iseq))))
(defun forge-env ()
(let ((fe (make-instance 'forge-env)))
fe))
(make-instance 'forge-env))
(defvar *forge-env* (forge-env))
(defun dstack()
(data-stack *forge-env*))
(defun activate-package(p)
(let ((old (current-package)))
(setf (slot-value *forge-env* 'current-package) p)
old))
(defun dstack() (data-stack *forge-env*))
(defun words () (slot-value *forge-env* 'words))
(defun set-word (w fn) (setf (gethash w (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)
(register sym fn :slot 'comp-words))
(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)))
(defmacro reg (sym &body body)
`(register ',sym #'(lambda () ,@body) :sf-builtin))
(defun register (sym fn &key package (slot 'words))
(let* ((p (or package (current-package)))
(w (intern (string sym) p))
(words (slot-value *forge-env* slot)))
(setf (gethash w words) fn)))
;;; builtins
(defmacro reg (sym &body body)
`(register ',sym #'(lambda () ,@body)))
(defvar lit #'(lambda () (pushd (isq-next (fip)))))
(defun init-forge-env ()
(defun setup-builtins ()
(reg add (pushd (+ (popd) (popd))))
(reg mul (pushd (* (popd) (popd))))
(reg dup (pushd (car (dstack))))
(register 'lit lit :sf-builtin)
(register 'lit lit)
(register-comp-word 'def
#'(lambda ()
(let* ((name (isq-next (frp)))
(code (comp (isq-next (frp)))))
(register name #'(lambda () (call code)))))
:sf-builtin)
)
#'(lambda ()
(let* ((name (isq-next (frp)))
(code (comp (isq-next (frp)))))
(register name #'(lambda () (call code))))))
(activate-package :sf-user))
;;; compiler, interpreter
@ -138,7 +138,7 @@
(defun comp-symbol (sym)
(let* ((w (get-word sym))
(comp-fn (get-comp-fn w)))
(comp-fn (gethash w (comp-words))))
(if comp-fn
(funcall comp-fn)
(comp-item (gethash w (words))))))
@ -153,9 +153,6 @@
(if w
(return-from get-word w))))))
(defun get-comp-fn (w)
(gethash w (comp-words)))
;;; internal definitions / forge-env pseudo-methods
(defun popd () (pop (data-stack *forge-env*)))
@ -172,7 +169,3 @@
(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))

5
test/test-forge.lisp
View file

@ -12,8 +12,9 @@
(in-package :scopes/test-forge)
(defun run ()
(let ((t:*test-suite* (t:test-suite "forge")))
(forge:init-forge-env)
(let ((t:*test-suite* (t:test-suite "forge"))
(forge:*forge-env* (forge:forge-env)))
(forge:setup-builtins)
(test-iseq)
(test-exec)
;(format t "~%data-stack ~a" (dstack))