diff --git a/forge/forge-legacy.lisp b/forge/forge-legacy.lisp new file mode 100644 index 0000000..9cefc6c --- /dev/null +++ b/forge/forge-legacy.lisp @@ -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))) diff --git a/forge/forge.lisp b/forge/forge.lisp index 9cefc6c..f4b0e74 100644 --- a/forge/forge.lisp +++ b/forge/forge.lisp @@ -6,22 +6,51 @@ (: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)) + #:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add)) (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 () ((data-stack :initform nil - :reader data-stack - :accessor data-stack!) - (vocabulary :initform (list *builtins*) - :accessor vocabulary))) + :accessor data-stack) + (cp :initform (make-iseq) + :accessor cp) + (ip :initform (make-iseq) + :accessor ip))) + +;;; forge environment (defun forge-env () (let ((fe (make-instance 'forge-env))) - (push (make-hash-table :test 'equalp) (vocabulary fe)) fe)) (defvar *forge-env* (forge-env)) @@ -48,11 +77,7 @@ (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 find-word (key)) (defun comp (inp) (let ((code nil)) @@ -70,77 +95,9 @@ (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 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))) diff --git a/test/test-forge-legacy.lisp b/test/test-forge-legacy.lisp new file mode 100644 index 0000000..0776d5c --- /dev/null +++ b/test/test-forge-legacy.lisp @@ -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)) diff --git a/test/test-forge.lisp b/test/test-forge.lisp index 0776d5c..985288c 100644 --- a/test/test-forge.lisp +++ b/test/test-forge.lisp @@ -13,44 +13,18 @@ (defun run () (let ((t:*test-suite* (t:test-suite "forge"))) - (test-seq) - (test-exec) + (test-iseq) + ;(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-iseq () + (let ((seq (forge:make-iseq))) + (forge:isq-add seq 1) + (forge:isq-add seq 2) + (== (forge:isq-next seq) 1) + (== (forge:isq-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))