simplify forge code: use special variable *forge-env*

forge/forge.lisp

@@ -4,7 +4,8 @@
 
 (defpackage :scopes/forge
   (:use :common-lisp)
-  (:export #:forge-env #:data-stack #:exec #:exec-str #:repl))
+  (:export #:*forge-env*
+           #:forge-env #:dstack #:exec #:exec-str #:repl))
 
 (in-package :scopes/forge)
 
@@ -22,37 +23,42 @@
     (push (make-hash-table :test 'equalp) (vocabulary fe))
     fe))
 
-(defun exec-str (fe s)
-  (exec fe (read-from-string 
+(defvar *forge-env* (forge-env))
+
+(defun dstack()
+  (data-stack *forge-env*))
+
+(defun exec-str (s)
+  (exec (read-from-string 
              (concatenate 'string "(" s ")"))))
 
-(defun exec (fe code)
+(defun exec (code)
   (dolist (x code)
     (typecase x
-      (symbol (funcall (comp1 fe x) fe))
-      (compiled-function (funcall x fe))
-      (t (pushd fe x)))))
+      (symbol (funcall (comp1 x)))
+      (compiled-function (funcall x))
+      (t (pushd x)))))
 
-(defun repl (fe)
+(defun repl ()
   (do ((input (read-line) (read-line))) ((string= input "q") nil)
-    (exec-str fe input)))
+    (exec-str input)))
 
-(defun find-word (fe key)
+(defun find-word (key)
   (let ((k (string-downcase (symbol-name key))))
-    (dolist (voc (vocabulary fe))
+    (dolist (voc (vocabulary *forge-env*))
       (let ((v (gethash k voc)))
         (if v (return v))))))
 
-(defun comp (fe inp)
+(defun comp (inp)
   (let ((code nil))
     (dolist (item inp)
-      (setf code (cons (comp1 fe item) code)))
+      (setf code (cons (comp1 item) code)))
     (reverse code)))
 
-(defun comp1 (fe item)
+(defun comp1 (item)
   (typecase item
-    (symbol (find-word fe item))
-    (cons (comp fe item))
+    (symbol (find-word item))
+    (cons (comp item))
     (t item)))
 
 (defun register (voc key fn)
@@ -63,44 +69,44 @@
 
 (defun reg-b (key fn) (register *builtins* key fn))
 
-(reg-b "+" #'(lambda (fe) (pushd fe (+ (popd fe) (popd fe)))))
-(reg-b "*" #'(lambda (fe) (pushd fe (* (popd fe) (popd fe)))))
+(reg-b "+" #'(lambda () (pushd (+ (popd) (popd)))))
+(reg-b "*" #'(lambda () (pushd (* (popd) (popd)))))
 
-(reg-b "dup" #'(lambda (fe) (pushd fe (car (data-stack fe)))))
+(reg-b "dup" #'(lambda () (pushd (car (dstack)))))
 
-(reg-b "?" #'(lambda (fe) (format t "~a~%" (popd fe))))
-(reg-b "??" #'(lambda (fe) (format t "~a~%" (data-stack fe))))
+(reg-b "?" #'(lambda () (format t "~a~%" (popd))))
+(reg-b "??" #'(lambda () (format t "~a~%" (dstack))))
 
-(reg-b "def" #'(lambda (fe) 
-  (let* ((name (popd fe)) 
-         (code (comp fe (popd fe))))
-    (register (voc fe) name #'(lambda (fe) (exec fe code))))))
+(reg-b "def" #'(lambda () 
+  (let* ((name (popd)) 
+         (code (comp (popd))))
+    (register (voc) name #'(lambda () (exec code))))))
 
-(reg-b "const" #'(lambda (fe)
-  (let ((name (popd fe))
-        (value (popd fe)))
-    (register (voc fe) name #'(lambda (fe) (pushd fe value))))))
+(reg-b "const" #'(lambda ()
+  (let ((name (popd))
+        (value (popd)))
+    (register (voc) name #'(lambda () (pushd value))))))
 
-(reg-b "var" #'(lambda (fe)
-  (let ((name (popd fe))
-        (var (list (popd fe))))
-    (register (voc fe) name #'(lambda (fe) 
-      (pushd fe #'(lambda (fn) 
+(reg-b "var" #'(lambda ()
+  (let ((name (popd))
+        (var (list (popd))))
+    (register (voc) name #'(lambda () 
+      (pushd #'(lambda (fn) 
         (funcall fn var))))))))
 
-(reg-b "get" #'(lambda (fe)
-  (funcall (popd fe) #'(lambda (x) (pushd fe (car x))))))
+(reg-b "get" #'(lambda ()
+  (funcall (popd) #'(lambda (x) (pushd (car x))))))
 
-(reg-b "put" #'(lambda (fe)
-  (let ((fn (popd fe))
-        (vl (popd fe)))
+(reg-b "put" #'(lambda ()
+  (let ((fn (popd))
+        (vl (popd)))
     (funcall fn #'(lambda (x) (setf (car x) vl))))))
 
 ; internal definitions
 
-(defun voc (fe) (car (vocabulary fe)))
+(defun voc () (car (vocabulary *forge-env*)))
 
-(defun popd (fe) (pop (data-stack! fe)))
+(defun popd () (pop (data-stack! *forge-env*)))
 
-(defun pushd (fe v) (push v (data-stack! fe)))
+(defun pushd (v) (push v (data-stack! *forge-env*)))
 

test/test-forge.lisp

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

test/test-storage.lisp

@@ -8,7 +8,8 @@
                     (:tracking :scopes/storage/tracking) 
                     (:t :scopes/testing))
   (:export #:run #:try
-           #:*db-config-postgres* #:*db-config-sqlite*))
+           #:*db-config-postgres* #:*db-config-sqlite*)
+  (:import-from :scopes/testing #:==))
 
 (in-package :scopes/test-storage)
 
@@ -31,4 +32,4 @@
     (storage:drop-table st :tracks)
     (tracking:create-table st :tracks '(taskid username))
     ;(setf (scs:data tr) nil)
-    (t:== (tracking:data tr) nil)))
+    (== (tracking:data tr) nil)))

testing.lisp

@@ -10,7 +10,7 @@
 
 (in-package :scopes/testing)
 
-(defparameter *tst* nil)
+(defvar *tst* nil)
 
 (defclass test-suite ()
   ((result :initform nil