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

5
test/test-forge.lisp
View file

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