clean-up: remove obsolete stuff, minor immprovements

forge/x-forge.lisp

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

storage/tracking.lisp

@@ -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)
+   (storage :reader storage :initarg :storage)))
-   (item-head-fields :accessor item-head-fields)))
 
 (defun make-container (st)
   (make-instance 'container :short-name :trk :storage st))

test/x-test-forge.lisp

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

util/async.lisp

@@ -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)
+            (sb-sys:interactive-interrupt (condition)
-              (format t "~&async:standard-job: ~a~%" e)))
+              (util:lgi condition)))
           (data tsk)))
       (setf (status tsk) :done)
       (funcall teardown tsk))))