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

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)))

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)))

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))

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))