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

work in progress: rewrite of forge implementation; keep old versions in ...-legacy files

Browse source
This commit is contained in:
Helmut Merz 2024-05-23 10:33:16 +02:00
parent 79432f7101
commit b6e1e3ccd4
4 changed files with 249 additions and 116 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

146
forge/forge-legacy.lisp Normal file
View file

@ -0,0 +1,146 @@
;;; cl-scopes/forge - may the forge be with you!
;;;; A Forth-like interpreter implemented in Common Lisp.
(defpackage :scopes/forge
(:use :common-lisp)
(:export #:*forge-env*
#:forge-env #:dstack #:exec #:exec-str #:repl
#:make-seq #:seq-all #:seq-cur #:seq-next #:seq-end #:seq-add))
(in-package :scopes/forge)
(defvar *builtins* (make-hash-table :test 'equalp))
(defclass forge-env ()
((data-stack :initform nil
:reader data-stack
:accessor data-stack!)
(vocabulary :initform (list *builtins*)
:accessor vocabulary)))
(defun forge-env ()
(let ((fe (make-instance 'forge-env)))
(push (make-hash-table :test 'equalp) (vocabulary fe))
fe))
(defvar *forge-env* (forge-env))
(defun dstack()
(data-stack *forge-env*))
(defun exec-str (s)
(exec (read-from-string
(concatenate 'string "(" s ")"))))
(defun exec (code)
(dolist (x code)
(typecase x
(symbol (funcall (comp1 x)))
(compiled-function (funcall x))
(t (pushd x)))))
(defun call (code)
(dolist (x code)
(funcall x)))
(defun repl ()
(do ((input (read-line) (read-line))) ((string= input "q") nil)
(exec-str input)))
(defun find-word (key)
(let ((k (string-downcase (symbol-name key))))
(dolist (voc (vocabulary *forge-env*))
(let ((v (gethash k voc)))
(if v (return v))))))
(defun comp (inp)
(let ((code nil))
(dolist (item inp)
(setf code (cons (comp1 item) code)))
(reverse code)))
(defun comp1 (item)
(typecase item
(symbol (find-word item))
(cons (comp item))
(t item)))
(defun register (voc key fn)
(let ((k (if (symbolp key) (symbol-name key) key)))
(setf (gethash (string-downcase k) voc) fn)))
; built-in primitives
(defun reg-b (key fn) (register *builtins* key fn))
(reg-b "+" #'(lambda () (pushd (+ (popd) (popd)))))
(reg-b "*" #'(lambda () (pushd (* (popd) (popd)))))
(reg-b "dup" #'(lambda () (pushd (car (dstack)))))
(reg-b "?" #'(lambda () (format t "~a~%" (popd))))
(reg-b "??" #'(lambda () (format t "~a~%" (dstack))))
(reg-b "def" #'(lambda ()
(let* ((name (popd))
(code (comp (popd))))
(register (voc) name #'(lambda () (call code))))))
(reg-b "const" #'(lambda ()
(let ((name (popd))
(value (popd)))
(register (voc) name #'(lambda () (pushd value))))))
(reg-b "var" #'(lambda ()
(let ((name (popd))
(var (list (popd))))
(register (voc) name #'(lambda ()
(pushd #'(lambda (fn)
(funcall fn var))))))))
(reg-b "get" #'(lambda ()
(funcall (popd) #'(lambda (x) (pushd (car x))))))
(reg-b "put" #'(lambda ()
(let ((fn (popd))
(vl (popd)))
(funcall fn #'(lambda (x) (setf (car x) vl))))))
; internal definitions
(defun voc () (car (vocabulary *forge-env*)))
(defun popd () (pop (data-stack! *forge-env*)))
(defun pushd (v) (push v (data-stack! *forge-env*)))
; sequence
(defclass seq ()
((start :reader start :initform (list nil) :initarg :start)
(cur :accessor cur)
(end :accessor end)))
(defun make-seq (&optional start)
(let* ((start (cons nil start))
(seq (make-instance 'seq :start start)))
(setf (cur seq) (setf (end seq) start))
seq))
(defun seq-all (seq)
(cdr (start seq)))
(defun seq-cur (seq)
(car (cur seq)))
(defun seq-end (seq)
(car (end seq)))
(defun seq-next (seq)
(pop (cur seq))
(car (cur seq)))
(defun seq-add (seq v)
(setf (cdr (end seq)) (list v))
(pop (end seq)))

121
forge/forge.lisp
View file

@ -6,22 +6,51 @@
(: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-seq #:seq-all #:seq-cur #:seq-next #:seq-end #:seq-add)) #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add))
(in-package :scopes/forge) (in-package :scopes/forge)
(defvar *builtins* (make-hash-table :test 'equalp)) ;;; iseq: iterable sequence
(defclass iseq ()
((start :reader start :initform (list nil) :initarg :start)
(cur :accessor cur)
(end :accessor end)))
(defun make-iseq (&optional start)
(let* ((start (cons nil start))
(seq (make-instance 'iseq :start start)))
(setf (cur seq) (setf (end seq) start))
seq))
(defun isq-all (seq)
(cdr (start seq)))
(defun isq-cur (seq)
(car (cur seq)))
(defun isq-end (seq)
(car (end seq)))
(defun isq-next (seq)
(pop (cur seq))
(car (cur seq)))
(defun isq-add (seq v)
(setf (cdr (end seq)) (list v))
(pop (end seq)))
(defclass forge-env () (defclass forge-env ()
((data-stack :initform nil ((data-stack :initform nil
:reader data-stack :accessor data-stack)
:accessor data-stack!) (cp :initform (make-iseq)
(vocabulary :initform (list *builtins*) :accessor cp)
:accessor vocabulary))) (ip :initform (make-iseq)
:accessor ip)))
;;; forge environment
(defun forge-env () (defun forge-env ()
(let ((fe (make-instance 'forge-env))) (let ((fe (make-instance 'forge-env)))
(push (make-hash-table :test 'equalp) (vocabulary fe))
fe)) fe))
(defvar *forge-env* (forge-env)) (defvar *forge-env* (forge-env))
@ -48,11 +77,7 @@
(do ((input (read-line) (read-line))) ((string= input "q") nil) (do ((input (read-line) (read-line))) ((string= input "q") nil)
(exec-str input))) (exec-str input)))
(defun find-word (key) (defun find-word (key))
(let ((k (string-downcase (symbol-name key))))
(dolist (voc (vocabulary *forge-env*))
(let ((v (gethash k voc)))
(if v (return v))))))
(defun comp (inp) (defun comp (inp)
(let ((code nil)) (let ((code nil))
@ -70,77 +95,9 @@
(let ((k (if (symbolp key) (symbol-name key) key))) (let ((k (if (symbolp key) (symbol-name key) key)))
(setf (gethash (string-downcase k) voc) fn))) (setf (gethash (string-downcase k) voc) fn)))
; built-in primitives
(defun reg-b (key fn) (register *builtins* key fn))
(reg-b "+" #'(lambda () (pushd (+ (popd) (popd)))))
(reg-b "*" #'(lambda () (pushd (* (popd) (popd)))))
(reg-b "dup" #'(lambda () (pushd (car (dstack)))))
(reg-b "?" #'(lambda () (format t "~a~%" (popd))))
(reg-b "??" #'(lambda () (format t "~a~%" (dstack))))
(reg-b "def" #'(lambda ()
(let* ((name (popd))
(code (comp (popd))))
(register (voc) name #'(lambda () (call code))))))
(reg-b "const" #'(lambda ()
(let ((name (popd))
(value (popd)))
(register (voc) name #'(lambda () (pushd value))))))
(reg-b "var" #'(lambda ()
(let ((name (popd))
(var (list (popd))))
(register (voc) name #'(lambda ()
(pushd #'(lambda (fn)
(funcall fn var))))))))
(reg-b "get" #'(lambda ()
(funcall (popd) #'(lambda (x) (pushd (car x))))))
(reg-b "put" #'(lambda ()
(let ((fn (popd))
(vl (popd)))
(funcall fn #'(lambda (x) (setf (car x) vl))))))
; internal definitions ; internal definitions
(defun voc () (car (vocabulary *forge-env*))) (defun popd () (pop (data-stack *forge-env*)))
(defun popd () (pop (data-stack! *forge-env*))) (defun pushd (v) (push v (data-stack *forge-env*)))
(defun pushd (v) (push v (data-stack! *forge-env*)))
; sequence
(defclass seq ()
((start :reader start :initform (list nil) :initarg :start)
(cur :accessor cur)
(end :accessor end)))
(defun make-seq (&optional start)
(let* ((start (cons nil start))
(seq (make-instance 'seq :start start)))
(setf (cur seq) (setf (end seq) start))
seq))
(defun seq-all (seq)
(cdr (start seq)))
(defun seq-cur (seq)
(car (cur seq)))
(defun seq-end (seq)
(car (end seq)))
(defun seq-next (seq)
(pop (cur seq))
(car (cur seq)))
(defun seq-add (seq v)
(setf (cdr (end seq)) (list v))
(pop (end seq)))

56
test/test-forge-legacy.lisp Normal file
View file

@ -0,0 +1,56 @@
;;; cl-scopes/test/test-forge
;;;; testing facility for scopes/forge
(defpackage :scopes/test-forge
(:use :common-lisp)
(:local-nicknames (:forge :scopes/forge)
(:t :scopes/testing))
(:export #:run)
(:import-from :scopes/testing #:deftest #:==))
(in-package :scopes/test-forge)
(defun run ()
(let ((t:*test-suite* (t:test-suite "forge")))
(test-seq)
(test-exec)
;(format t "~%data-stack ~a" (dstack))
(test-def)
(test-exec-str)
(test-const)
(test-var)
(t:show-result)))
(deftest test-seq ()
(let ((seq (forge:make-seq)))
(forge:seq-add seq 1)
(forge:seq-add seq 2)
(== (forge:seq-next seq) 1)
(== (forge:seq-end seq) 2)))
(deftest test-exec ()
(forge:exec '(4 2 +))
(== (car (forge:dstack)) 6))
(deftest test-def ()
(forge:exec '((dup *) "square" def))
(forge:exec '(7 square))
(== (car (forge:dstack)) 49))
(deftest test-exec-str ()
(forge:exec-str "16 square")
(== (car (forge:dstack)) 256))
(deftest test-const ()
(forge:exec-str "17 \"c1\" const")
(forge:exec-str "c1 square")
(== (car (forge:dstack)) 289))
(deftest test-var ()
(forge:exec '(24 "v1" var))
(forge:exec '(v1 get 2 *))
(== (car (forge:dstack)) 48)
(forge:exec '(5 v1 put))
(forge:exec '(v1 get 2 *))
(== (car (forge:dstack)) 10))

42
test/test-forge.lisp
View file

@ -13,44 +13,18 @@
(defun run () (defun run ()
(let ((t:*test-suite* (t:test-suite "forge"))) (let ((t:*test-suite* (t:test-suite "forge")))
(test-seq) (test-iseq)
(test-exec) ;(test-exec)
;(format t "~%data-stack ~a" (dstack)) ;(format t "~%data-stack ~a" (dstack))
(test-def)
(test-exec-str)
(test-const)
(test-var)
(t:show-result))) (t:show-result)))
(deftest test-seq () (deftest test-iseq ()
(let ((seq (forge:make-seq))) (let ((seq (forge:make-iseq)))
(forge:seq-add seq 1) (forge:isq-add seq 1)
(forge:seq-add seq 2) (forge:isq-add seq 2)
(== (forge:seq-next seq) 1) (== (forge:isq-next seq) 1)
(== (forge:seq-end seq) 2))) (== (forge:isq-end seq) 2)))
(deftest test-exec () (deftest test-exec ()
(forge:exec '(4 2 +)) (forge:exec '(4 2 +))
(== (car (forge:dstack)) 6)) (== (car (forge:dstack)) 6))
(deftest test-def ()
(forge:exec '((dup *) "square" def))
(forge:exec '(7 square))
(== (car (forge:dstack)) 49))
(deftest test-exec-str ()
(forge:exec-str "16 square")
(== (car (forge:dstack)) 256))
(deftest test-const ()
(forge:exec-str "17 \"c1\" const")
(forge:exec-str "c1 square")
(== (car (forge:dstack)) 289))
(deftest test-var ()
(forge:exec '(24 "v1" var))
(forge:exec '(v1 get 2 *))
(== (car (forge:dstack)) 48)
(forge:exec '(5 v1 put))
(forge:exec '(v1 get 2 *))
(== (car (forge:dstack)) 10))