remove obsolete legacy code
This commit is contained in:
parent
15fe5242f6
commit
70bdac68a2
3 changed files with 0 additions and 252 deletions
|
|
@ -1,146 +0,0 @@
|
||||||
;;; 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)))
|
|
||||||
|
|
@ -1,50 +0,0 @@
|
||||||
;;; cl-scopes/forge/seq-functioinal.list
|
|
||||||
;;; a functional closure-based implementation of
|
|
||||||
;;; sequence with three pointers
|
|
||||||
|
|
||||||
;;; not used, stored here for later reference
|
|
||||||
|
|
||||||
(defun make-seq ()
|
|
||||||
(let* ((start (list nil))
|
|
||||||
(cur start)
|
|
||||||
(end start)
|
|
||||||
(args (list start cur end)))
|
|
||||||
#'(lambda (fn)
|
|
||||||
(setf args (apply fn args)))))
|
|
||||||
|
|
||||||
(defun seq-all (seq)
|
|
||||||
(let (rv)
|
|
||||||
(funcall seq #'(lambda (start cur end)
|
|
||||||
(setf rv (cdr start))
|
|
||||||
(list start cur end)))
|
|
||||||
rv))
|
|
||||||
|
|
||||||
(defun seq-cur (seq)
|
|
||||||
(let (rv)
|
|
||||||
(funcall seq #'(lambda (start cur end)
|
|
||||||
(setf rv (car cur))
|
|
||||||
(list start cur end)))
|
|
||||||
rv))
|
|
||||||
|
|
||||||
(defun seq-end (seq)
|
|
||||||
(let (rv)
|
|
||||||
(funcall seq #'(lambda (start cur end)
|
|
||||||
(setf rv (car end))
|
|
||||||
(list start cur end)))
|
|
||||||
rv))
|
|
||||||
|
|
||||||
(defun seq-next (seq)
|
|
||||||
(let (rv)
|
|
||||||
(funcall seq #'(lambda (start cur end)
|
|
||||||
(pop cur)
|
|
||||||
(setf rv (car cur))
|
|
||||||
(list start cur end)))
|
|
||||||
rv))
|
|
||||||
|
|
||||||
(defun seq-add (seq v)
|
|
||||||
(funcall seq #'(lambda (start cur end)
|
|
||||||
(setf (cdr end) (list v))
|
|
||||||
(pop end)
|
|
||||||
(list start cur end)))
|
|
||||||
nil)
|
|
||||||
|
|
||||||
|
|
@ -1,56 +0,0 @@
|
||||||
;;; 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))
|
|
||||||
Loading…
Add table
Reference in a new issue