clean-up: remove obsolete stuff, minor immprovements
This commit is contained in:
parent
230594e98e
commit
7d612bf823
4 changed files with 3 additions and 286 deletions
|
|
@ -1,224 +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* #:setup-builtins #:activate-package
|
||||
#:forge-env #:dstack #:exec #:exec-str #:repl
|
||||
#:make-iseq #:isq-all #:isq-cur #:isq-next #:isq-end #:isq-add
|
||||
#:with-trace))
|
||||
|
||||
(defpackage :sf-builtin)
|
||||
(defpackage :sf-user)
|
||||
|
||||
(in-package :scopes/forge)
|
||||
|
||||
(defmacro with-trace (&body body)
|
||||
`(let ((*features* (cons :forge-trace *features*))) ,@body))
|
||||
|
||||
;;; 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)))
|
||||
|
||||
;;; forge environment
|
||||
|
||||
(defclass forge-env ()
|
||||
((data-stack :initform nil :accessor data-stack)
|
||||
(words :initform (make-hash-table :test #'eq))
|
||||
(comp-words :initform (make-hash-table))
|
||||
(words-rev :initform (make-hash-table))
|
||||
(words-meta :initform (make-hash-table))
|
||||
(packages :initform '(:sf-user :sf-builtin))
|
||||
(current-package :initform :sf-builtin)
|
||||
(ip :initform (make-iseq))
|
||||
(rp) (cp)))
|
||||
|
||||
(defun forge-env ()
|
||||
(make-instance 'forge-env))
|
||||
|
||||
(defvar *forge-env* (forge-env))
|
||||
|
||||
(defun activate-package(p)
|
||||
(let ((old (current-package)))
|
||||
(setf (slot-value *forge-env* 'current-package) p)
|
||||
old))
|
||||
|
||||
(defun dstack() (data-stack *forge-env*))
|
||||
|
||||
(defun words () (slot-value *forge-env* 'words))
|
||||
|
||||
(defun comp-words () (slot-value *forge-env* 'comp-words))
|
||||
|
||||
(defun register-comp-word (sym fn &key code)
|
||||
(register sym fn :slot 'comp-words :code code))
|
||||
|
||||
(defun register (sym fn &key (slot 'words) code)
|
||||
(let* ((w (intern (string sym) (current-package)))
|
||||
(words (slot-value *forge-env* slot)))
|
||||
(setf (gethash w words) fn)
|
||||
(setf (gethash fn (slot-value *forge-env* 'words-rev)) w)
|
||||
(if code
|
||||
(setf (gethash w (slot-value *forge-env* 'words-meta)) code))))
|
||||
|
||||
;;; builtins
|
||||
|
||||
(defmacro reg (sym &body body)
|
||||
`(register ',sym #'(lambda () ,@body)))
|
||||
|
||||
(defun lit () (pushd (isq-next (fip))))
|
||||
|
||||
(defun do-reg (&optional (fn #'register))
|
||||
(let* ((name (popd))
|
||||
(code (popd)))
|
||||
(funcall fn name #'(lambda () (call code)) :code code)))
|
||||
|
||||
(defun do-quote ()
|
||||
(let ((quoted (read-next)))
|
||||
#+forge-trace (format t " - do-quote: ~a" quoted)
|
||||
(comp-item #'lit) (comp-item quoted)))
|
||||
|
||||
(defun do-comp ()
|
||||
(let* ((sym (read-next))
|
||||
(w (get-word sym)))
|
||||
;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
|
||||
(comp-item (gethash w (comp-words)))))
|
||||
|
||||
(defun setup-builtins ()
|
||||
(register 'lit #'lit)
|
||||
(register 'reg #'do-reg)
|
||||
|
||||
(reg + (pushd (+ (popd) (popd))))
|
||||
(reg * (pushd (* (popd) (popd))))
|
||||
(reg dup (pushd (car (dstack))))
|
||||
(reg swap (let ((a (popd)) (b (popd))) (pushd a) (pushd b)))
|
||||
(reg ? (format t "~a~%" (popd)))
|
||||
(reg ?? (format t "~a~%" (dstack)))
|
||||
(reg get (pushd (cadr (popd))))
|
||||
(reg set (setf (cadr (popd)) (popd)))
|
||||
(reg wrap (pushd (list #'lit (popd))))
|
||||
(reg defer (comp-item (isq-next (fip))))
|
||||
(reg regc (do-reg #'register-comp-word))
|
||||
|
||||
(register-comp-word 'quote #'do-quote)
|
||||
(register-comp-word 'comp #'do-comp)
|
||||
|
||||
(activate-package :sf-user))
|
||||
|
||||
;;; trace functionality
|
||||
|
||||
(defun decompile-item (item)
|
||||
(or (gethash item (slot-value *forge-env* 'words-rev))
|
||||
(typecase item
|
||||
(cons (decompile item))
|
||||
(t item))))
|
||||
|
||||
(defun decompile (code)
|
||||
(mapcar #'decompile-item code))
|
||||
|
||||
(defun trace-call (code)
|
||||
(format t "~%call: ~a" (decompile code)))
|
||||
|
||||
;;; compiler, interpreter
|
||||
|
||||
(defun exec-str (s)
|
||||
(exec (read-from-string
|
||||
(concatenate 'string "(" s ")"))))
|
||||
|
||||
(defun repl ()
|
||||
(do ((input (read-line) (read-line)))
|
||||
((string= input "q") (dstack))
|
||||
(exec-str input)))
|
||||
|
||||
(defun exec (code)
|
||||
(call (comp code)))
|
||||
|
||||
(defun call (code)
|
||||
#+forge-trace (trace-call code)
|
||||
(let ((old-ip (fip))
|
||||
(ip (make-iseq code)))
|
||||
(setf (slot-value *forge-env* 'ip) ip)
|
||||
(do ((item (isq-next ip) (isq-next ip)))
|
||||
((null item))
|
||||
(funcall item))
|
||||
(setf (slot-value *forge-env* 'ip) old-ip)
|
||||
#+forge-trace (format t "~% - stack: ~A" (dstack))
|
||||
(dstack)))
|
||||
|
||||
(defun comp (slist)
|
||||
#+forge-trace (format t "~%comp: ~a" slist)
|
||||
(let ((cp (make-iseq))
|
||||
(inp (make-iseq slist)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(do ((item (isq-next inp) (isq-next inp)))
|
||||
((null item))
|
||||
(typecase item
|
||||
(symbol (comp-symbol item))
|
||||
(cons (let ((sub (comp item)))
|
||||
(setf (slot-value *forge-env* 'cp) cp)
|
||||
(setf (slot-value *forge-env* 'rp) inp)
|
||||
(comp-item #'lit)
|
||||
(comp-item sub)))
|
||||
(t (comp-item #'lit) (comp-item item)))))
|
||||
(isq-all (fcp)))
|
||||
|
||||
(defun comp-symbol (sym)
|
||||
(let* ((w (get-word sym))
|
||||
(comp-fn (gethash w (comp-words))))
|
||||
;(format t "~%comp-symbol ~a ~a ~a" sym w comp-fn)
|
||||
(if comp-fn
|
||||
(funcall comp-fn)
|
||||
(comp-item (gethash w (words))))))
|
||||
|
||||
(defun get-word (sym)
|
||||
(let ((name (string sym)))
|
||||
(dolist (p (packages))
|
||||
(let ((w (find-symbol name p)))
|
||||
(if w
|
||||
(return-from get-word w))))))
|
||||
|
||||
;;; internal definitions / forge-env pseudo-methods
|
||||
|
||||
(defun popd () (pop (data-stack *forge-env*)))
|
||||
|
||||
(defun pushd (v) (push v (data-stack *forge-env*)))
|
||||
|
||||
(defun fcp () (slot-value *forge-env* 'cp))
|
||||
|
||||
(defun comp-item (item) (isq-add (fcp) item))
|
||||
|
||||
(defun fip () (slot-value *forge-env* 'ip))
|
||||
|
||||
(defun read-next () (isq-next (slot-value *forge-env* 'rp)))
|
||||
|
||||
(defun packages () (slot-value *forge-env* 'packages))
|
||||
|
||||
(defun current-package () (slot-value *forge-env* 'current-package))
|
||||
|
||||
|
|
@ -56,8 +56,7 @@
|
|||
:initform #'default-indexes)
|
||||
(force-insert-when :reader force-insert-when
|
||||
:initarg :force-insert-when :initform nil)
|
||||
(storage :reader storage :initarg :storage)
|
||||
(item-head-fields :accessor item-head-fields)))
|
||||
(storage :reader storage :initarg :storage)))
|
||||
|
||||
(defun make-container (st)
|
||||
(make-instance 'container :short-name :trk :storage st))
|
||||
|
|
|
|||
|
|
@ -1,58 +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")))
|
||||
;(forge:*forge-env* (forge:forge-env)))
|
||||
(setf forge:*forge-env* (forge:forge-env))
|
||||
(forge:setup-builtins)
|
||||
(test-iseq)
|
||||
(test-exec)
|
||||
(test-def)
|
||||
(test-const)
|
||||
(test-var)
|
||||
(t:show-result)))
|
||||
|
||||
(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-str "4 2 +")
|
||||
(== (car (forge:dstack)) 6))
|
||||
|
||||
(deftest test-def ()
|
||||
(forge:exec-str "(comp quote defer regc) quote defc regc")
|
||||
(forge:exec-str "(comp quote defer reg) defc def")
|
||||
(forge:exec-str "(dup *) def square")
|
||||
(forge:exec-str "7 square")
|
||||
(== (car (forge:dstack)) 49))
|
||||
|
||||
(deftest test-const ()
|
||||
(forge:exec-str "(defer wrap comp quote defer reg) defc const")
|
||||
(forge:exec-str "11 const eleven")
|
||||
(forge:exec-str "eleven square")
|
||||
(== (car (forge:dstack)) 121))
|
||||
|
||||
(deftest test-var ()
|
||||
(forge:exec-str "(defer wrap defer wrap comp quote defer reg) defc var")
|
||||
(forge:exec-str "7 var myvar")
|
||||
(forge:exec-str "myvar get square")
|
||||
(== (car (forge:dstack)) 49)
|
||||
(forge:exec-str "8 myvar set")
|
||||
(forge:exec-str "myvar get square")
|
||||
(== (car (forge:dstack)) 64))
|
||||
|
||||
|
|
@ -37,8 +37,8 @@
|
|||
(loop for msg = (lpq:pop-queue mb)
|
||||
until (eq msg +quit-message+)
|
||||
do (funcall handle-message tsk msg))
|
||||
(sb-sys:interactive-interrupt (e)
|
||||
(format t "~&async:standard-job: ~a~%" e)))
|
||||
(sb-sys:interactive-interrupt (condition)
|
||||
(util:lgi condition)))
|
||||
(data tsk)))
|
||||
(setf (status tsk) :done)
|
||||
(funcall teardown tsk))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue