diff --git a/forge/forge.lisp b/forge/forge.lisp index 8d013e2..e5c9bbe 100644 --- a/forge/forge.lisp +++ b/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*))) diff --git a/test/test-forge.lisp b/test/test-forge.lisp index c751d37..5c0be66 100644 --- a/test/test-forge.lisp +++ b/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)) diff --git a/test/test-storage.lisp b/test/test-storage.lisp index a4f2d64..791a12c 100644 --- a/test/test-storage.lisp +++ b/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))) diff --git a/testing.lisp b/testing.lisp index f6f5948..423b957 100644 --- a/testing.lisp +++ b/testing.lisp @@ -10,7 +10,7 @@ (in-package :scopes/testing) -(defparameter *tst* nil) +(defvar *tst* nil) (defclass test-suite () ((result :initform nil