From 7d612bf8232ad1350490c468ec0c5dcd3ecf3a1f Mon Sep 17 00:00:00 2001 From: Helmut Merz Date: Sun, 16 Mar 2025 16:04:01 +0100 Subject: [PATCH] clean-up: remove obsolete stuff, minor immprovements --- forge/x-forge.lisp | 224 ----------------------------------------- storage/tracking.lisp | 3 +- test/x-test-forge.lisp | 58 ----------- util/async.lisp | 4 +- 4 files changed, 3 insertions(+), 286 deletions(-) delete mode 100644 forge/x-forge.lisp delete mode 100644 test/x-test-forge.lisp diff --git a/forge/x-forge.lisp b/forge/x-forge.lisp deleted file mode 100644 index be7ed83..0000000 --- a/forge/x-forge.lisp +++ /dev/null @@ -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)) - diff --git a/storage/tracking.lisp b/storage/tracking.lisp index e188af7..cfe79a2 100644 --- a/storage/tracking.lisp +++ b/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) - (item-head-fields :accessor item-head-fields))) + (storage :reader storage :initarg :storage))) (defun make-container (st) (make-instance 'container :short-name :trk :storage st)) diff --git a/test/x-test-forge.lisp b/test/x-test-forge.lisp deleted file mode 100644 index b36b55a..0000000 --- a/test/x-test-forge.lisp +++ /dev/null @@ -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)) - diff --git a/util/async.lisp b/util/async.lisp index 92dc3e5..32526e8 100644 --- a/util/async.lisp +++ b/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) - (format t "~&async:standard-job: ~a~%" e))) + (sb-sys:interactive-interrupt (condition) + (util:lgi condition))) (data tsk))) (setf (status tsk) :done) (funcall teardown tsk))))