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

store reverse word index and word metadata index in forge-env

Browse source
This commit is contained in:
Helmut Merz 2024-05-29 15:00:29 +02:00
parent fb88c0b934
commit b5dabdb73b
1 changed files with 22 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
forge/forge.lisp
View file

@ -51,13 +51,14 @@
(defclass forge-env () (defclass forge-env ()
((data-stack :initform nil :accessor data-stack) ((data-stack :initform nil :accessor data-stack)
(words :initform (make-hash-table)) (words :initform (make-hash-table :test #'eq))
(comp-words :initform (make-hash-table)) (comp-words :initform (make-hash-table))
(words-rev :initform (make-hash-table))
(words-meta :initform (make-hash-table))
(packages :initform '(:sf-user :sf-builtin)) (packages :initform '(:sf-user :sf-builtin))
(current-package :initform :sf-builtin) (current-package :initform :sf-builtin)
(rp :initform (make-iseq)) (ip :initform (make-iseq))
(cp :initform (make-iseq)) (rp) (cp)))
(ip :initform (make-iseq))))
(defun forge-env () (defun forge-env ()
(make-instance 'forge-env)) (make-instance 'forge-env))
@ -75,13 +76,16 @@
(defun comp-words () (slot-value *forge-env* 'comp-words)) (defun comp-words () (slot-value *forge-env* 'comp-words))
(defun register-comp-word (sym fn) (defun register-comp-word (sym fn &key code)
(register sym fn 'comp-words)) (register sym fn :slot 'comp-words :code code))
(defun register (sym fn &optional (slot 'words)) (defun register (sym fn &key (slot 'words) code)
(let* ((w (intern (string sym) (current-package))) (let* ((w (intern (string sym) (current-package)))
(words (slot-value *forge-env* slot))) (words (slot-value *forge-env* slot)))
(setf (gethash w words) fn))) (setf (gethash w words) fn)
(setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
(if code
(setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
;;; builtins ;;; builtins
@ -95,12 +99,12 @@
(defun do-reg () (defun do-reg ()
(let* ((name (popd)) (let* ((name (popd))
(code (popd))) (code (popd)))
(register name #'(lambda () (call code))))) (register name #'(lambda () (call code)) :code code)))
(defun do-regc () (defun do-regc ()
(let* ((name (popd)) (let* ((name (popd))
(code (popd))) (code (popd)))
(register-comp-word name #'(lambda () (call code))))) (register-comp-word name #'(lambda () (call code)) :code code)))
(defun do-quote () (comp-item #'lit) (comp-item (read-next))) (defun do-quote () (comp-item #'lit) (comp-item (read-next)))
@ -131,6 +135,13 @@
;;; compiler, interpreter ;;; compiler, interpreter
(defun do-trace (code)
(format t "~%~a"
(mapcar
#'(lambda (f)
(or (gethash f (slot-value *forge-env* 'words-rev)) f))
code)))
(defun exec-str (s) (defun exec-str (s)
(exec (read-from-string (exec (read-from-string
(concatenate 'string "(" s ")")))) (concatenate 'string "(" s ")"))))
@ -144,7 +155,7 @@
(call (comp code))) (call (comp code)))
(defun call (code) (defun call (code)
#+forge-trace (print code) #+forge-trace (do-trace code)
(let ((old-ip (fip)) (let ((old-ip (fip))
(ip (make-iseq code))) (ip (make-iseq code)))
(setf (slot-value *forge-env* 'ip) ip) (setf (slot-value *forge-env* 'ip) ip)