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

forge rewrite: improvements: get-symbol, access to cp, ip

Browse source
This commit is contained in:
Helmut Merz 2024-05-23 14:50:32 +02:00
parent abd8e6e2e0
commit 4d2f6655ef
2 changed files with 26 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
forge/forge.lisp
View file

@ -6,17 +6,10 @@
(:use :common-lisp) (:use :common-lisp)
(:export #:*forge-env* (:export #:*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))
#:add))
(in-package :scopes/forge) (in-package :scopes/forge)
;;; builtins
(defvar add #'(lambda () (pushd (cl:+ (popd) (popd)))))
(defvar lit #'(lambda () (pushd (isq-next (ip *forge-env*)))))
;;; iseq: iterable sequence ;;; iseq: iterable sequence
(defclass iseq () (defclass iseq ()
@ -46,16 +39,14 @@
(defun isq-add (seq v) (defun isq-add (seq v)
(setf (cdr (end seq)) (list v)) (setf (cdr (end seq)) (list v))
(pop (end seq))) (pop (end seq)))
(defclass forge-env ()
((data-stack :initform nil
:accessor data-stack)
(cp :initform (make-iseq)
:accessor cp)
(ip :initform (make-iseq)
:accessor ip)))
;;; forge environment ;;; forge environment
(defclass forge-env ()
((data-stack :initform nil :accessor data-stack)
(cp :initform (make-iseq))
(ip :initform (make-iseq))))
(defun forge-env () (defun forge-env ()
(let ((fe (make-instance 'forge-env))) (let ((fe (make-instance 'forge-env)))
fe)) fe))
@ -65,6 +56,14 @@
(defun dstack() (defun dstack()
(data-stack *forge-env*)) (data-stack *forge-env*))
;;; builtins
(defvar add #'(lambda () (pushd (+ (popd) (popd)))))
(defvar lit #'(lambda () (pushd (isq-next (fip)))))
;;; compiler, interpreter
(defun exec-str (s) (defun exec-str (s)
(exec (read-from-string (exec (read-from-string
(concatenate 'string "(" s ")")))) (concatenate 'string "(" s ")"))))
@ -78,24 +77,27 @@
(defun call (code) (defun call (code)
(let ((ip (make-iseq code))) (let ((ip (make-iseq code)))
(setf (ip *forge-env*) ip) (setf (slot-value *forge-env* 'ip) ip)
(do ((item (isq-next ip) (isq-next ip))) (do ((item (isq-next ip) (isq-next ip)))
((null item)) ((null item))
(funcall item)))) (funcall item))))
(defun get-word (sym)
(symbol-value (find-symbol (string sym) :scopes/forge)))
(defun comp (slist) (defun comp (slist)
(setf (cp *forge-env*) (make-iseq)) (setf (slot-value *forge-env* 'cp) (make-iseq))
(let ((inp (make-iseq slist))) (let ((inp (make-iseq slist)))
(do ((item (isq-next inp) (isq-next inp))) (do ((item (isq-next inp) (isq-next inp)))
((null item)) ((null item))
(typecase item (typecase item
(symbol (comp1 (symbol-value item))) (symbol (comp1 (get-word item)))
(cons (comp1 lit) (comp1 (comp item))) (cons (comp1 lit) (comp1 (comp item)))
(t (comp1 lit) (comp1 item))))) (t (comp1 lit) (comp1 item)))))
(isq-all (cp *forge-env*))) (isq-all (fcp)))
(defun comp1 (item) (defun comp1 (item)
(isq-add (cp *forge-env*) item)) (isq-add (fcp) item))
;;; internal definitions ;;; internal definitions
@ -103,3 +105,6 @@
(defun pushd (v) (push v (data-stack *forge-env*))) (defun pushd (v) (push v (data-stack *forge-env*)))
(defun fcp () (slot-value *forge-env* 'cp))
(defun fip () (slot-value *forge-env* 'ip))

2
test/test-forge.lisp
View file

@ -26,5 +26,5 @@
(== (forge:isq-end seq) 2))) (== (forge:isq-end seq) 2)))
(deftest test-exec () (deftest test-exec ()
(forge:exec '(4 2 forge:add)) (forge:exec-str "4 2 add")
(== (car (forge:dstack)) 6)) (== (car (forge:dstack)) 6))