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

work in progress: define 'def'

Browse source
This commit is contained in:
Helmut Merz 2024-05-24 11:32:41 +02:00
parent 4d2f6655ef
commit 272430f36c
2 changed files with 42 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
forge/forge.lisp
View file

@ -44,6 +44,8 @@
(defclass forge-env ()
((data-stack :initform nil :accessor data-stack)
(comp-words :initform (make-hash-table))
(rp :initform (make-iseq))
(cp :initform (make-iseq))
(ip :initform (make-iseq))))
@ -56,12 +58,26 @@
(defun dstack()
(data-stack *forge-env*))
(defun define-comp-word (sym fn)
(setf (gethash sym (slot-value *forge-env* 'comp-words)) fn))
;;; builtins
(defvar add #'(lambda () (pushd (+ (popd) (popd)))))
(defvar dup #'(lambda () (pushd (car (dstack)))))
(defvar lit #'(lambda () (pushd (isq-next (fip)))))
(define-comp-word 'def
#'(lambda ()
(let* ((name (isq-next (frp)))
(code (isq-next (frp))))
(print name)
(print code)
;(eval `(defvar ,name (comp code)))
)))
;;; compiler, interpreter
(defun exec-str (s)
@ -82,29 +98,42 @@
((null item))
(funcall item))))
(defun get-word (sym)
(symbol-value (find-symbol (string sym) :scopes/forge)))
(defun comp (slist)
(setf (slot-value *forge-env* 'cp) (make-iseq))
(let ((inp (make-iseq slist)))
(setf (slot-value *forge-env* 'rp) inp)
(do ((item (isq-next inp) (isq-next inp)))
((null item))
(typecase item
(symbol (comp1 (get-word item)))
(cons (comp1 lit) (comp1 (comp item)))
(t (comp1 lit) (comp1 item)))))
(symbol (comp-symbol item))
(cons (comp-item lit) (comp-item (comp item)))
(t (comp-item lit) (comp-item item)))))
(isq-all (fcp)))
(defun comp1 (item)
(defun comp-symbol (sym)
(let* ((word (get-word sym))
(comp-word (get-comp-word word)))
(if comp-word
(funcall comp-word)
(comp-item (symbol-value word)))))
(defun comp-item (item)
(isq-add (fcp) item))
(defun get-word (sym)
(intern (string sym) :scopes/forge))
(defun get-comp-word (sym)
(gethash sym (slot-value *forge-env* 'comp-words)))
;;; internal definitions
(defun popd () (pop (data-stack *forge-env*)))
(defun pushd (v) (push v (data-stack *forge-env*)))
(defun frp () (slot-value *forge-env* 'rp))
(defun fcp () (slot-value *forge-env* 'cp))
(defun fip () (slot-value *forge-env* 'ip))

6
test/test-forge.lisp
View file

@ -16,6 +16,7 @@
(test-iseq)
(test-exec)
;(format t "~%data-stack ~a" (dstack))
(test-def)
(t:show-result)))
(deftest test-iseq ()
@ -28,3 +29,8 @@
(deftest test-exec ()
(forge:exec-str "4 2 add")
(== (car (forge:dstack)) 6))
(deftest test-def ()
(forge:exec-str "def square (dup *)"))
;(forge:exec-str "7 square")
;(== (car (forge:dstack)) 49))