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

forge/sf: new forge-env class, work in progress: put stack and vocabulary there

Browse source
This commit is contained in:
Helmut Merz 2024-09-13 09:39:07 +02:00
parent 65fbf0aac4
commit 5df8a852b1
1 changed files with 20 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
forge/sf.lisp
View file

@ -6,22 +6,30 @@
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:iter :scopes/util/iter) (:local-nicknames (:iter :scopes/util/iter)
(:util :scopes/util)) (:util :scopes/util))
(:export #:*input* #:*stack* (:export #:forge-env #:vocabulary #:stack
#:*forge-env* #:*stack* #:*input* #:*code*
#:word #:comp-word #:word #:comp-word
#:exec-list #:exec-input #:comp-input #:call #:exec-list #:exec-input #:comp-input #:call
#:comp-item
#:lit #:reg #:reg2 #:reg-code #:lit #:reg #:reg2 #:reg-code
#:pushd #:popd #:peekd)) #:pushd #:popd #:peekd))
(in-package :scopes/forge/sf) (in-package :scopes/forge/sf)
(defclass forge-env ()
((vocabulary :reader vocabulary :initform (make-hash-table))
(func-index :reader func-index :initform (make-hash-table))
(stack :reader stack :initform nil)))
(defvar *forge-env* (make-instance 'forge-env))
(defvar *stack* nil) (defvar *stack* nil)
(defvar *input* nil) (defvar *input* nil)
(defvar *buffer* nil) (defvar *buffer* nil)
(defvar *code* nil) (defvar *code* nil)
(defvar *func-index* (make-hash-table))
(defmethod print-object :around ((fn function) s) (defmethod print-object :around ((fn function) s)
(let ((sym (gethash fn *func-index*))) (let ((sym (gethash fn (func-index *forge-env*))))
(if sym (if sym
(print-unreadable-object (fn s) (format s "~s" sym)) (print-unreadable-object (fn s) (format s "~s" sym))
(call-next-method)))) (call-next-method))))
@ -43,7 +51,7 @@
(:method ((it symbol)) (:method ((it symbol))
(let ((v (symbol-value it))) (let ((v (symbol-value it)))
(when v (when v
(util:lgi it v) ;(util:lgi it v)
(comp-item v))))) (comp-item v)))))
;;;; class word* ;;;; class word*
@ -80,12 +88,12 @@
(defun call (code) (defun call (code)
(let ((*code* (make-instance 'iter:list-iterator :data code))) (let ((*code* (make-instance 'iter:list-iterator :data code)))
(util:lgi code) ;(util:lgi code)
(iter:process *code* #'funcall))) (iter:process *code* #'funcall)))
(defun reg (sym fn &optional (cls 'word)) (defun reg (sym fn &optional (cls 'word))
(setf (symbol-value sym) (make-instance cls :func fn)) (setf (symbol-value sym) (make-instance cls :func fn))
(setf (gethash fn *func-index*) sym)) (setf (gethash fn (func-index *forge-env*)) sym))
(defun reg2 (sym fn) (defun reg2 (sym fn)
(reg sym #'(lambda () (pushd (funcall fn (popd) (popd)))))) (reg sym #'(lambda () (pushd (funcall fn (popd) (popd))))))
@ -113,7 +121,8 @@
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:f :scopes/forge/sf) (:local-nicknames (:f :scopes/forge/sf)
(:iter :scopes/util/iter)) (:iter :scopes/util/iter))
(:export #:add #:mul #:dup #:swp #:in #:? #:lit #:defer (:export #:add #:mul #:dup #:swp #:in #:? #:lit
#:comp-pop #:comp-in #:comp
#:<comp #:reg #:regc #:/>)) #:<comp #:reg #:regc #:/>))
(in-package :sf-builtin) (in-package :sf-builtin)
@ -125,9 +134,11 @@
(f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b)))) (f:reg 'swp #'(lambda () (let ((a (f:popd)) (b (f:popd))) (f:pushd a) (f:pushd b))))
(f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*)))) (f:reg 'in #'(lambda () (f:pushd (iter:next-value f:*input*))))
(f:reg 'lit #'f:lit) (f:reg 'lit #'f:lit)
(f:reg 'defer #'(lambda () (push (iter:next-value f::*code*) f::*buffer*)))
(f:reg 'comp-pop #'(lambda () (f:comp-item (popd))))
(f:reg 'comp-in #'(lambda () (f:comp-item (iter:next-value f:*input*))))
(f:reg 'comp #'(lambda () (f:comp-item (iter:next-value f:*code*))))
(f:reg '<comp #'f:comp-input) (f:reg '<comp #'f:comp-input)