1.1--- a/.hgignore Fri Apr 19 22:00:00 2024 -0400
1.2+++ b/.hgignore Sat Apr 20 22:14:30 2024 -0400
1.3@@ -1,3 +1,4 @@
1.4+./x$
1.5 .*Cargo.lock$
1.6 .*target/.*
1.7 .*system-index.txt$
2.1--- a/emacs/default.el Fri Apr 19 22:00:00 2024 -0400
2.2+++ b/emacs/default.el Sat Apr 20 22:14:30 2024 -0400
2.3@@ -73,11 +73,11 @@
2.4 ;;; Packages
2.5 (with-eval-after-load 'package
2.6 (setq package-archives
2.7- '(("gnu" . "https://elpa.gnu.org/packages/")
2.8- ("nongnu" . "https://elpa.nongnu.org/nongnu/")
2.9- ("melpa" . "https://melpa.org/packages/"))
2.10- use-package-always-ensure t
2.11- use-package-expand-minimally t)
2.12+ '(("gnu" . "https://elpa.gnu.org/packages/")
2.13+ ("nongnu" . "https://elpa.nongnu.org/nongnu/")
2.14+ ("melpa" . "https://melpa.org/packages/"))
2.15+ use-package-always-ensure t
2.16+ use-package-expand-minimally t)
2.17 (add-packages
2.18 eglot-x ;; LSP extensions
2.19 org-web-tools ;; web parsing
2.20@@ -170,15 +170,6 @@
2.21 ;;; Dired
2.22
2.23 ;;; Lisp
2.24-(use-package lisp-mode
2.25- :ensure nil
2.26- :custom
2.27- inferior-lisp-program "sbcl --dynamic-space-size=8G"
2.28- scheme-program-name "gsi"
2.29- guile-program "guile"
2.30- cmulisp-program "lisp"
2.31- scsh-program "scsh")
2.32-
2.33 (use-package slime
2.34 :ensure t
2.35 :init
2.36@@ -193,6 +184,7 @@
2.37 slime-mrepl
2.38 slime-sbcl-exts
2.39 slime-cape ;; ext
2.40+ slime-cl-indent
2.41 ;; slime-snapshot
2.42 slime-sprof
2.43 slime-tramp
2.44@@ -204,6 +196,12 @@
2.45 (put 'reinitialize-instance 'common-lisp-indent-function 1)
2.46 (add-hook 'slime-mode-hook #'slime-cape-maybe-enable)
2.47 (add-hook 'slime-repl-mode-hook #'slime-cape-maybe-enable)
2.48+ (define-common-lisp-style "core" "Core Common Lisp Indentation Style"
2.49+ (:inherit "sbcl")
2.50+ (:indentation
2.51+ (defpkg (as defpackage))
2.52+ (define-package (as defpackage))))
2.53+
2.54 (slime-setup)
2.55 (defvar slime-toggle nil)
2.56 (defun slime-toggle ()
2.57@@ -242,6 +240,16 @@
2.58 ;; (define-key slime-prefix-map (kbd "i") 'clouseau-inspect)
2.59 (setq slime-threads-update-interval 1))
2.60
2.61+(use-package lisp-mode
2.62+ :ensure nil
2.63+ :custom
2.64+ inferior-lisp-program "sbcl --dynamic-space-size=8G"
2.65+ scheme-program-name "gsi"
2.66+ guile-program "guile"
2.67+ cmulisp-program "lisp"
2.68+ common-lisp-stype-default "core"
2.69+ scsh-program "scsh")
2.70+
2.71 ;;; Eglot
2.72 (with-eval-after-load 'eglot
2.73 (unless (package-installed-p 'eglot-x)
2.74@@ -357,8 +365,8 @@
2.75 current-prefix-arg))
2.76 (let* ((date (if verbose
2.77 comment-timestamp-format-verbose
2.78- prog-comment-timestamp-format-concise))
2.79- (string (format "%s %s: " keyword (format-time-string date)))
2.80+ prog-comment-timestamp-format-concise))
2.81+ (string (format "%s %s: " keyword (format-time-string date)))
2.82 (beg (point)))
2.83 (cond
2.84 ((or (eq beg (point-at-bol))
2.85@@ -413,7 +421,7 @@
2.86 "Copy register A to B."
2.87 (interactive
2.88 (list (register-read-with-preview "From register: ")
2.89- (register-read-with-preview "To register: ")))
2.90+ (register-read-with-preview "To register: ")))
2.91 (set-register b (get-register a)))
2.92
2.93 (defun buffer-to-register (register &optional delete)
2.94@@ -456,19 +464,19 @@
2.95 `(mapc (lambda (x) (add-outline-hook (car x) (cadr x))) ',pairs))
2.96
2.97 (outline-hooks (asm-mode ";;;+")
2.98- (nasm-mode ";;;+")
2.99- (rust-mode "\\(//!\\|////+\\)")
2.100- (sh-mode "###+")
2.101- (sh-script-mode "###+")
2.102- (makefile-mode "###+")
2.103- (conf-mode "###+")
2.104- (common-lisp-mode)
2.105- (emacs-lisp-mode)
2.106- (lisp-data-mode)
2.107- (org-mode)
2.108- (css-mode)
2.109- (html-mode)
2.110- (skel-mode))
2.111+ (nasm-mode ";;;+")
2.112+ (rust-mode "\\(//!\\|////+\\)")
2.113+ (sh-mode "###+")
2.114+ (sh-script-mode "###+")
2.115+ (makefile-mode "###+")
2.116+ (conf-mode "###+")
2.117+ (common-lisp-mode)
2.118+ (emacs-lisp-mode)
2.119+ (lisp-data-mode)
2.120+ (org-mode)
2.121+ (css-mode)
2.122+ (html-mode)
2.123+ (skel-mode))
2.124
2.125 ;;; Scratch
2.126 (defcustom default-scratch-buffer-mode 'lisp-interaction-mode
2.127@@ -543,7 +551,7 @@
2.128 bufname)
2.129 (while (progn
2.130 (setq bufname
2.131- (concat "*scratch"
2.132+ (concat "*scratch"
2.133 (if (= n 0) "" (int-to-string n))
2.134 "*"))
2.135 (setq n (1+ n))
2.136@@ -574,10 +582,10 @@
2.137 eshell-destroy-buffer-when-process-dies t)
2.138
2.139 (add-hook 'eshell-mode-hook
2.140- (lambda ()
2.141- (eshell/alias "d" "dired $1")
2.142- (eshell/alias "ff" "find-file $1")
2.143- (eshell/alias "hgfe" "hg-fast-export.sh")))
2.144+ (lambda ()
2.145+ (eshell/alias "d" "dired $1")
2.146+ (eshell/alias "ff" "find-file $1")
2.147+ (eshell/alias "hgfe" "hg-fast-export.sh")))
2.148
2.149 (defun eshell/clear ()
2.150 "Clear the eshell buffer."
2.151@@ -640,16 +648,16 @@
2.152 ;; captures
2.153 (setq org-capture-templates
2.154 '(("t" "task" entry (file "inbox.org") "* %^{title}\n- %?" :prepend t)
2.155- ("1" "current-task-item" item (clock) "%i%?")
2.156- ("2" "current-task-checkbox" checkitem (clock) "%i%?")
2.157- ("3" "current-task-region" plain (clock) "%i" :immediate-finish t :empty-lines 1)
2.158- ("4" "current-task-kill" plain (clock) "%c" :immediate-finish t :empty-lines 1)
2.159- ("l" "log" item (file+headline "log.org" "log") "%U %?" :prepend t)
2.160- ("s" "secret" table-line (file+function "krypt" org-ask-location) "| %^{key} | %^{val} |" :immediate-finish t :kill-buffer t)
2.161- ("n" "note" plain (file+function "notes.org" org-ask-location) "%?")
2.162- ("i" "idea" entry (file "inbox.org") "* OUTLINE %?\n:notes:\n:end:\n- _outline_ [/]\n - [ ] \n - [ ] \n- _refs_" :prepend t)
2.163- ("b" "bug" entry (file "inbox.org") "* FIX %?\n- _review_\n- _fix_\n- _test_" :prepend t)
2.164- ("r" "research" entry (file "inbox.org") "* RESEARCH %?\n:notes:\n:end:\n- _refs_" :prepend t)))
2.165+ ("1" "current-task-item" item (clock) "%i%?")
2.166+ ("2" "current-task-checkbox" checkitem (clock) "%i%?")
2.167+ ("3" "current-task-region" plain (clock) "%i" :immediate-finish t :empty-lines 1)
2.168+ ("4" "current-task-kill" plain (clock) "%c" :immediate-finish t :empty-lines 1)
2.169+ ("l" "log" item (file+headline "log.org" "log") "%U %?" :prepend t)
2.170+ ("s" "secret" table-line (file+function "krypt" org-ask-location) "| %^{key} | %^{val} |" :immediate-finish t :kill-buffer t)
2.171+ ("n" "note" plain (file+function "notes.org" org-ask-location) "%?")
2.172+ ("i" "idea" entry (file "inbox.org") "* OUTLINE %?\n:notes:\n:end:\n- _outline_ [/]\n - [ ] \n - [ ] \n- _refs_" :prepend t)
2.173+ ("b" "bug" entry (file "inbox.org") "* FIX %?\n- _review_\n- _fix_\n- _test_" :prepend t)
2.174+ ("r" "research" entry (file "inbox.org") "* RESEARCH %?\n:notes:\n:end:\n- _refs_" :prepend t)))
2.175 (setq org-html-htmlize-output-type 'css
2.176 org-html-head-include-default-style nil
2.177 ;; comp2 default
2.178@@ -659,17 +667,17 @@
2.179
2.180 (setq org-structure-template-alist
2.181 '(("s" . "src")
2.182- ("e" . "src emacs-lisp")
2.183- ("x" . "src shell")
2.184- ("l" . "src lisp")
2.185- ("h" . "export html")
2.186- ("p" . "src python")
2.187- ("r" . "src rust")
2.188- ("E" . "example")
2.189- ("q" . "quote")
2.190- ("c" . "center")
2.191- ("C" . "comment")
2.192- ("v" . "verse")))
2.193+ ("e" . "src emacs-lisp")
2.194+ ("x" . "src shell")
2.195+ ("l" . "src lisp")
2.196+ ("h" . "export html")
2.197+ ("p" . "src python")
2.198+ ("r" . "src rust")
2.199+ ("E" . "example")
2.200+ ("q" . "quote")
2.201+ ("c" . "center")
2.202+ ("C" . "comment")
2.203+ ("v" . "verse")))
2.204
2.205 (setopt org-preview-latex-image-directory "~/.emacs.d/.cache/ltximg"
2.206 org-latex-image-default-width "8cm"
2.207@@ -782,7 +790,7 @@
2.208 (command-execute 'outline-next-visible-heading)
2.209 ;; disable (message) that org-set-tags generates
2.210 (flet ((message (&rest ignored) nil))
2.211- (org-set-tags 1 t))
2.212+ (org-set-tags 1 t))
2.213 (set-buffer-modified-p b-m-p))
2.214 (error nil)))))
2.215
2.216@@ -821,7 +829,7 @@
2.217 (defun org-agenda-reschedule-to-today ()
2.218 (interactive)
2.219 (flet ((org-read-date (&rest rest) (current-time)))
2.220- (call-interactively 'org-agenda-schedule)))
2.221+ (call-interactively 'org-agenda-schedule)))
2.222
2.223 ;; Patch org-mode to use vertical splitting
2.224 (defadvice org-prepare-agenda (after org-fix-split)
3.1--- a/lisp/app/bin/homer.lisp Fri Apr 19 22:00:00 2024 -0400
3.2+++ b/lisp/app/bin/homer.lisp Sat Apr 20 22:14:30 2024 -0400
3.3@@ -7,7 +7,6 @@
3.4 (:export :main :home-config))
3.5
3.6 (in-package :bin/homer)
3.7-
3.8 (defvar *user* (sb-posix:getenv "USER"))
3.9 (defvar *user-homedir* (user-homedir-pathname))
3.10 (defvar *default-user-homerc* (merge-pathnames ".homerc" *user-homedir*))
3.11@@ -25,6 +24,10 @@
3.12 (browser :initarg :browser :type (or pathname browser-user-config))
3.13 (paths :initarg :paths :type list)))
3.14
3.15+(defmethod print-object ((self home-config) stream)
3.16+ (print-unreadable-object (self stream :type t)
3.17+ (format stream "~S ~A" :id (format-sxhash (id self)))))
3.18+
3.19 (defun find-homer-symbol (s)
3.20 (find-symbol* (symbol-name s) :homer nil))
3.21
3.22@@ -42,14 +45,13 @@
3.23 (error 'sxp-syntax-error))))
3.24
3.25 ;; obj -> ast
3.26-(defmethod build-ast ((self sk-project) &key (nullp nil) (exclude '(ast id)))
3.27+(defmethod build-ast ((self home-config) &key (nullp nil) (exclude '(ast id)))
3.28 (setf (ast self)
3.29 (unwrap-object self
3.30 :slots t
3.31 :methods nil
3.32 :nullp nullp
3.33 :exclude exclude)))
3.34-
3.35
3.36 (defun load-homerc (&optional (file *default-user-homerc*))
3.37 "Load a homerc configuration from FILE. Defaults to ~/.homerc."
3.38@@ -58,16 +60,16 @@
3.39
3.40 (defopt homer-help (print-help $cli))
3.41 (defopt homer-version (print-version $cli))
3.42-(defopt homer-log-level (setq *log-level* (when $val :debug)))
3.43+(defopt homer-log-level (when $val (setq *log-level* :debug)))
3.44
3.45 (defcmd homer-show
3.46 (describe (load-homerc)))
3.47
3.48-
3.49 (define-cli $cli
3.50 :name "homer"
3.51 :version "0.1.0"
3.52- :description "home manager"
3.53+ :description "user home manager"
3.54+ :thunk homer-show
3.55 :opts (make-opts
3.56 (:name level :global t :description "set the log level" :thunk homer-log-level)
3.57 (:name help :global t :description "print help" :thunk homer-help)
3.58@@ -76,9 +78,10 @@
3.59 (:name show :thunk homer-show)))
3.60
3.61 (defun run ()
3.62- (with-cli (opts cmds args) $cli
3.63- (do-cmd $cli)
3.64- (debug-opts $cli)))
3.65+ (let ((*log-level* :info))
3.66+ (with-cli (opts cmds args) $cli
3.67+ (do-cmd $cli)
3.68+ (debug-opts $cli))))
3.69
3.70 (defmain ()
3.71 (let ((*print-readably* t))
4.1--- a/lisp/app/bin/skel.lisp Fri Apr 19 22:00:00 2024 -0400
4.2+++ b/lisp/app/bin/skel.lisp Sat Apr 20 22:14:30 2024 -0400
4.3@@ -1,47 +1,46 @@
4.4 ;;; Code:
4.5 (uiop:define-package :bin/skel
4.6- (:use :cl :std :cli :vc :sb-ext)
4.7+ (:use :cl :std :cli/clap :vc :sb-ext)
4.8 (:use-reexport :skel :log)
4.9 (:export :main))
4.10
4.11 (in-package :bin/skel)
4.12 (in-readtable :shell)
4.13-(setq *log-level* :info)
4.14 (defopt skc-help (print-help $cli))
4.15 (defopt skc-version (print-version $cli))
4.16-(defopt skc-log (setq *log-level* (when $val :debug :info)))
4.17+(defopt skc-log *log-level* (when $val (setq *log-level* :debug)))
4.18
4.19 ;; TODO 2023-10-13: almost there
4.20 (defopt skc-cfg
4.21 (when $val
4.22- (init-user-skelrc (parse-file-opt (car $args)))))
4.23-
4.24+ (init-user-skelrc (parse-file-opt $val))))
4.25+
4.26 (defcmd skc-config
4.27 (if $args
4.28 (describe (init-user-skelrc (parse-file-opt (car $args))))
4.29- (if-let ((cfg (probe-file *user-skelrc*)))
4.30- (describe (load-user-skelrc))
4.31- (describe (init-user-skelrc)))))
4.32+ (if (probe-file *user-skelrc*)
4.33+ (describe (load-user-skelrc))
4.34+ (describe (init-user-skelrc)))))
4.35
4.36 (defcmd skc-init
4.37- (let ((file (when $args (pop $args)))
4.38- (name (if (> $argc 1) (pop $args))))
4.39- (handler-bind
4.40- ((sb-ext:file-exists
4.41- #'(lambda (s)
4.42- (uiop:println (format nil "file already exists: ~A" (or file *default-skelfile*)))
4.43- (let ((f2 (read-line)))
4.44- (if (string= f2 "")
4.45- (error s)
4.46- (use-value f2 s))))))
4.47- (init-skelfile file name))))
4.48+ (let ((file (when $args (pop $args)))
4.49+ (name (if (> $argc 1) (pop $args))))
4.50+ (handler-bind
4.51+ ((sb-ext:file-exists
4.52+ #'(lambda (s)
4.53+ (uiop:println (format nil "file already exists: ~A" (or file *default-skelfile*)))
4.54+ (let ((f2 (read-line)))
4.55+ (if (string= f2 "")
4.56+ (error s)
4.57+ (use-value f2 s))))))
4.58+ (init-skelfile file name))))
4.59
4.60 (defcmd skc-describe
4.61- (describe
4.62- (find-skelfile
4.63- (if $args (pathname (car $args))
4.64- #P".")
4.65- :load t)))
4.66+ (describe
4.67+ (find-skelfile
4.68+ (if $args (pathname (car $args))
4.69+ #P".")
4.70+ :load t)))
4.71
4.72 (defcmd skc-inspect
4.73 (sb-ext:enable-debugger)
4.74@@ -52,9 +51,9 @@
4.75 :load t)))
4.76
4.77 (defcmd skc-show
4.78- (if $args
4.79- (find-skelfile (pathname (car $args)) :load t)
4.80- (find-skelfile #P"." :load t)))
4.81+ (if $args
4.82+ (find-skelfile (pathname (car $args)) :load t)
4.83+ (find-skelfile #P"." :load t)))
4.84
4.85 (defcmd skc-push
4.86 (case
4.87@@ -140,15 +139,12 @@
4.88
4.89 (defun run ()
4.90 (let ((*log-level* :info))
4.91- (in-package :std-user)
4.92- (in-package :skel)
4.93- (use-package :sb-ext)
4.94 (in-readtable :shell)
4.95 (with-cli (opts cmds) $cli
4.96 (load-skelrc)
4.97 ;; TODO 2024-01-01: need to parse out CMD opts from args slot - they still there
4.98 (do-cmd $cli)
4.99- (when (debug-p) (debug-opts $cli)))))
4.100+ (debug-opts $cli))))
4.101
4.102 (defmain ()
4.103 (run)
5.1--- a/lisp/lib/cli/clap.lisp Fri Apr 19 22:00:00 2024 -0400
5.2+++ b/lisp/lib/cli/clap.lisp Sat Apr 20 22:14:30 2024 -0400
5.3@@ -86,17 +86,19 @@
5.4 (declare (type symbol name))
5.5 `(,*default-cli-def* ,name (apply #'make-cli t (walk-cli-slots ',body))))
5.6
5.7-(defmacro defmain (ret &body body)
5.8+(defmacro defmain ((&optional ret) &body body)
5.9 "Define a CLI main function in the current package which returns RET."
5.10- (let ((main (symbolicate 'main)))
5.11- `(progn
5.12- (declaim (type stream output))
5.13+ (with-gensyms (retval)
5.14+ (let ((main (symbolicate 'main)))
5.15+ (info! (when ret (setf retval ret)))
5.16+ `(prog1
5.17 (defun ,main (&key (output *standard-output*))
5.18 "Run the top-level function and print to OUTPUT."
5.19+ (declare (stream output))
5.20 (let ((*standard-output* output))
5.21 (with-cli-handlers
5.22- (progn ,@body ,ret))))
5.23- (export '(,main)))))
5.24+ (progn ,@body ,@(unless (not (boundp 'retval)) (list retval))))))
5.25+ (export '(,main))))))
5.26
5.27 ;;; Utils
5.28 (defun make-cli (kind &rest slots)
6.1--- a/lisp/lib/cli/tests.lisp Fri Apr 19 22:00:00 2024 -0400
6.2+++ b/lisp/lib/cli/tests.lisp Sat Apr 20 22:14:30 2024 -0400
6.3@@ -198,7 +198,8 @@
6.4 "Test CLI prompts"
6.5 ;; TODO: needs to be compiled outside scope of test - contender for
6.6 ;; fixture API
6.7- (defprompt tpfoo "testing: ")
6.8+ (compile
6.9+ (defprompt tpfoo "testing: "))
6.10 (defvar tcoll nil)
6.11 (defvar thist nil)
6.12 (let ((*standard-input* (make-string-input-stream
6.13@@ -658,3 +659,13 @@
6.14 (is (find-exe "sbcl")))
6.15
6.16 (deftest clap-ast ())
6.17+
6.18+(defvar *test-target* nil)
6.19+
6.20+(deftest main-output ()
6.21+ (defmain (*test-target*)
6.22+ (let ((*test-target* t))
6.23+ *test-target*))
6.24+ (compile 'main)
6.25+ (is (main))
6.26+ (is (null *test-target*)))
7.1--- a/lisp/lib/cry/cry.asd Fri Apr 19 22:00:00 2024 -0400
7.2+++ b/lisp/lib/cry/cry.asd Sat Apr 20 22:14:30 2024 -0400
7.3@@ -15,5 +15,3 @@
7.4 :depends-on (:rt :cry)
7.5 :components ((:file "tests"))
7.6 :perform (test-op (o c) (symbol-call :rt :do-tests :cry)))
7.7-
7.8-
8.1--- a/lisp/lib/cry/pkg.lisp Fri Apr 19 22:00:00 2024 -0400
8.2+++ b/lisp/lib/cry/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
8.3@@ -2,6 +2,7 @@
8.4 ;; very unfortunate that ironclad takes the nickname 'crypto'
8.5 ;; (:nicknames :crypto)
8.6 (:nicknames :cryptography)
8.7+ (:shadowing-import-from :ironclad :integer-to-octets :octets-to-integer)
8.8 (:use :cl :std :sb-thread :sb-concurrency :ironclad :obj/db :obj/id)
8.9 (:export :crypto-error :crypto-token-expired :crypto-token-invalid
8.10 :crypto-key :token :crypto-token :password
9.1--- a/lisp/lib/dat/pkg.lisp Fri Apr 19 22:00:00 2024 -0400
9.2+++ b/lisp/lib/dat/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
9.3@@ -21,6 +21,7 @@
9.4 :define-macro :define-fmt :read-sxp-file :write-sxp-file
9.5 :read-sxp-string :write-sxp-string :read-sxp-stream :write-sxp-stream
9.6 :make-sxp :sxp :formp :form
9.7+ :file-read-forms
9.8 :wrap-object :unwrap-object))
9.9
9.10 (defpackage :dat/csv
10.1--- a/lisp/lib/dat/sxp.lisp Fri Apr 19 22:00:00 2024 -0400
10.2+++ b/lisp/lib/dat/sxp.lisp Sat Apr 20 22:14:30 2024 -0400
10.3@@ -141,5 +141,12 @@
10.4 (declare (type class class)
10.5 (type form form)))
10.6
10.7+(declaim (inline file-read-forms))
10.8+(defun file-read-forms (file)
10.9+ (aif (read-file-forms file)
10.10+ (if (> (length it) 1)
10.11+ it
10.12+ (car it))))
10.13+
10.14 ;; (defmacro define-fmt ())
10.15 ;; (defmacro define-macro ())
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/lisp/lib/krypt/err.lisp Sat Apr 20 22:14:30 2024 -0400
11.3@@ -0,0 +1,8 @@
11.4+;;; krypt/err.lisp --- Krypt Errors
11.5+
11.6+;;
11.7+
11.8+;;; Code:
11.9+(in-package :krypt)
11.10+
11.11+(deferror krypt-error (std-error) ())
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/lib/krypt/krypt.asd Sat Apr 20 22:14:30 2024 -0400
12.3@@ -0,0 +1,15 @@
12.4+(defsystem :krypt
12.5+ :version "0.1.0"
12.6+ :maintainer "ellis <ellis@rwest.io>"
12.7+ :bug-tracker "https://vc.compiler.company/comp/core/issues"
12.8+ :depends-on (:std :log :obj :dat :rdb)
12.9+ :serial t
12.10+ :components ((:file "pkg")
12.11+ (:file "err")
12.12+ (:file "krypt"))
12.13+ :in-order-to ((test-op (test-op :cry/tests))))
12.14+
12.15+(defsystem :cry/tests
12.16+ :depends-on (:rt :cry)
12.17+ :components ((:file "tests"))
12.18+ :perform (test-op (o c) (symbol-call :rt :do-tests :cry)))
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/lisp/lib/krypt/krypt.lisp Sat Apr 20 22:14:30 2024 -0400
13.3@@ -0,0 +1,44 @@
13.4+;;; krypt/krypt.lisp --- Krypt API
13.5+
13.6+;;
13.7+
13.8+;;; Code:
13.9+(in-package :krypt)
13.10+
13.11+(defparameter *default-user-kryptrc* #P"~/.kryptrc")
13.12+
13.13+(defclass krypt-config (sxp id)
13.14+ ((path :initform nil :initarg :path :type (or pathname null))))
13.15+
13.16+(defmethod print-object ((self krypt-config) stream)
13.17+ (print-unreadable-object (self stream :type t)
13.18+ (format stream "~S ~A" :id (format-sxhash (id self)))))
13.19+
13.20+(defun find-krypt-symbol (s)
13.21+ (find-symbol* (symbol-name s) :homer nil))
13.22+
13.23+(defmethod load-ast ((self krypt-config))
13.24+ (with-slots (ast) self
13.25+ (if (formp ast)
13.26+ ;; ast is valid, modify object, set ast nil
13.27+ (progn
13.28+ (sb-int:doplist (k v) ast
13.29+ (when-let ((s (find-krypt-symbol k)))
13.30+ (setf (slot-value self s) v))) ;; needs to be correct package
13.31+ (setf (ast self) nil)
13.32+ self)
13.33+ ;; invalid ast, signal error
13.34+ (error 'sxp-syntax-error))))
13.35+
13.36+(defmethod build-ast ((self krypt-config) &key (nullp nil) (exclude '(ast id)))
13.37+ (setf (ast self)
13.38+ (unwrap-object self
13.39+ :slots t
13.40+ :methods nil
13.41+ :nullp nullp
13.42+ :exclude exclude)))
13.43+
13.44+(defun load-kryptrc (&optional (file *default-user-kryptrc*))
13.45+ "Load a homerc configuration from FILE. Defaults to ~/.homerc."
13.46+ (let ((form (file-read-forms file)))
13.47+ (load-ast (make-instance 'krypt-config :ast form :path file :id (sxhash form)))))
14.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2+++ b/lisp/lib/krypt/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
14.3@@ -0,0 +1,9 @@
14.4+;;; krypt/pkg.lisp --- Krypt Packages
14.5+
14.6+;;
14.7+
14.8+;;; Code:
14.9+(defpackage :krypt
14.10+ (:use :cl :std :cry :dat/sxp :obj/id)
14.11+ (:export :krypt-error :*default-user-kryptrc*
14.12+ :krypt-config :load-kryptrc))
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/lib/krypt/tests.lisp Sat Apr 20 22:14:30 2024 -0400
15.3@@ -0,0 +1,14 @@
15.4+;;; krypt/tests.lisp --- Krypt Tests
15.5+
15.6+;;
15.7+
15.8+;;; Code:
15.9+(defpackage :krypt/tests
15.10+ (:use :cl :std :rt :krypt))
15.11+
15.12+(in-package :krypt/tests)
15.13+
15.14+(defsuite :krypt)
15.15+(in-suite :krypt)
15.16+
15.17+(deftest config ())
16.1--- a/lisp/lib/log/log.lisp Fri Apr 19 22:00:00 2024 -0400
16.2+++ b/lisp/lib/log/log.lisp Sat Apr 20 22:14:30 2024 -0400
16.3@@ -3,7 +3,7 @@
16.4 (deftype log-level-designator () '(member nil :fatal :error :warn :info :debug :trace t))
16.5
16.6 (declaim (log-level-designator *log-level*))
16.7-(defvar *log-level* :debug
16.8+(defparameter *log-level* :debug
16.9 "Logging is performed dynamically based on this variable. When NIL,
16.10 logging is disabled, which is equivalent to a level of :FATAL. When T,
16.11 Logging is enabled for all levels, which is equivalent to :TRACE.")
17.1--- a/lisp/lib/rdb/tests.lisp Fri Apr 19 22:00:00 2024 -0400
17.2+++ b/lisp/lib/rdb/tests.lisp Sat Apr 20 22:14:30 2024 -0400
17.3@@ -5,7 +5,7 @@
17.4
17.5 (defsuite :rdb)
17.6 (in-suite :rdb)
17.7-
17.8+(setq rt:*compile-tests* nil)
17.9 (rocksdb:load-rocksdb)
17.10 (setq *temp-db-destroy* t)
17.11
17.12@@ -22,7 +22,7 @@
17.13 "Ensure RDB-OPTS can be created, destructured, etc."
17.14 (let ((default (default-rdb-opts)))
17.15 ;; check defaults
17.16- (is (< 100 (hash-table-size (backfill-opts default))))
17.17+ (is (< 50 (hash-table-count (backfill-opts default :full t))))
17.18 (is (typep (rdb-opts-sap default) '(alien (* rocksdb-options))))
17.19 (is (eql t (get-opt default "create-if-missing")))
17.20 (is (eql t (set-opt default "enable-blob-files" t :push t)))
17.21@@ -92,7 +92,7 @@
17.22 (iter-seek-to-first it)
17.23 (is (sequence:emptyp (iter-key it)))
17.24 (is (sequence:emptyp (iter-val it)))
17.25- (is (iter-valid-p it))
17.26+ (is (not (iter-valid-p it)))
17.27 (iter-seek-to-last it)
17.28 (is (typep (iter-kv it) 'rdb-kv))
17.29 (is (sequence:emptyp (iter-key it)))
18.1--- a/lisp/lib/rt/pkg.lisp Fri Apr 19 22:00:00 2024 -0400
18.2+++ b/lisp/lib/rt/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
18.3@@ -133,7 +133,7 @@
18.4
18.5 ;;; Vars
18.6 (defvar *test-opts* '(optimize sb-c::instrument-consing))
18.7-(defvar *compile-tests* t
18.8+(defvar *compile-tests* nil
18.9 "When nil do not compile tests. With a value of t, tests are compiled
18.10 with default optimizations else the value is used to configure
18.11 compiler optimizations.")
18.12@@ -351,8 +351,8 @@
18.13 ;; (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
18.14 (profile :type list :accessor test-profile :initform nil :initarg :profile)
18.15 (args :type list :accessor test-args :initform nil :initarg :args)
18.16- (decl :type list :accessor test-decl :initform nil :initarg :decl)
18.17- (form :initarg :form :initform nil :type function-lambda-expression :accessor test-form)
18.18+ (declaration :type list :accessor test-declaration :initform nil :initarg :declaration)
18.19+ (form :initarg :form :initform nil :accessor test-form)
18.20 (doc :initarg :doc :type string :accessor test-doc)
18.21 (lock :initarg :lock :type boolean :accessor test-lock-p)
18.22 (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
18.23@@ -374,11 +374,9 @@
18.24
18.25 (defmethod print-object ((self test) stream)
18.26 (print-unreadable-object (self stream :type t :identity t)
18.27- (format stream "~A :fn ~A :args ~A :persist ~A"
18.28+ (format stream "~A :fn ~A"
18.29 (test-name self)
18.30- (test-fn self)
18.31- (test-args self)
18.32- (test-persist-p self))))
18.33+ (test-fn self))))
18.34
18.35 (defmethod push-result ((self test-result) (place test))
18.36 (with-slots (results) place
18.37@@ -390,6 +388,14 @@
18.38 (defmethod eval-test ((self test))
18.39 (eval `(progn ,@(test-form self))))
18.40
18.41+(defmethod funcall-test ((self test) &key declare)
18.42+ (unless (functionp (test-fn self))
18.43+ (trace! (setf (symbol-function (test-fn self))
18.44+ (eval `(lambda ()
18.45+ ,(when declare `(declare ,declare))
18.46+ ,@(test-form self))))))
18.47+ (funcall (test-fn self)))
18.48+
18.49 (defmethod compile-test ((self test) &key declare &allow-other-keys)
18.50 (compile
18.51 (test-fn self)
18.52@@ -425,15 +431,14 @@
18.53 (setq opt *test-opts*)
18.54 (setq opt (push *test-opts* opt)))
18.55 ;; TODO 2023-09-21: handle failures here
18.56- (ignore-some-conditions (style-warning) (funcall (compile-test self :declare opt)))
18.57+ (funcall (compile-test self :declare opt))
18.58 (setf %test-result (make-test-result :pass (test-fn self))))
18.59 (progn
18.60- (ignore-some-conditions (style-warning) (eval-test self))
18.61+ (funcall-test self)
18.62 (setf %test-result (make-test-result :pass (test-name self)))))))
18.63 (if *catch-test-errors*
18.64 (handler-bind
18.65- ((style-warning #'muffle-warning)
18.66- (error
18.67+ ((error
18.68 #'(lambda (c)
18.69 (setf %test-bail t)
18.70 (setf %test-result (make-test-result :fail c))
18.71@@ -691,7 +696,7 @@
18.72 ;; ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
18.73 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
18.74 ,@(when doc `(:doc ,doc))
18.75- ,@(when dec `(:decl ,dec)))))
18.76+ ,@(when dec `(:declaration ,dec)))))
18.77 ,(unless (getf pr :disabled) '(push-test obj *test-suite*))
18.78 obj)))
18.79
19.1--- a/lisp/lib/skel/core/obj.lisp Fri Apr 19 22:00:00 2024 -0400
19.2+++ b/lisp/lib/skel/core/obj.lisp Sat Apr 20 22:14:30 2024 -0400
19.3@@ -347,13 +347,6 @@
19.4 (error 'sxp-fmt-error)))
19.5 (t (write (ast self) :stream stream :pretty pretty :case case :readably t :array t :escape t))))
19.6
19.7-(declaim (inline file-read-forms))
19.8-(defun file-read-forms (file)
19.9- (aif (read-file-forms file)
19.10- (if (> (length it) 1)
19.11- it
19.12- (car it))))
19.13-
19.14 ;; file -> ast
19.15 (defmethod sk-read-file ((self sk-project) path)
19.16 (wrap self (file-read-forms path))
20.1--- a/lisp/lib/skel/pkg.lisp Fri Apr 19 22:00:00 2024 -0400
20.2+++ b/lisp/lib/skel/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
20.3@@ -71,7 +71,7 @@
20.4 :*default-user-skelrc* :*default-system-skel-config* :*skelfile-extension* :*skelfile-boundary*
20.5 :*default-skel-stash*
20.6 :*default-system-skelrc*
20.7- :file-read-forms :load-ast
20.8+ :load-ast
20.9 :sk-author :sk-path :sk-stash :sk-cache :sk-registry :sk-user
20.10 :sk-push :sk-pull
20.11 :edit-skelrc
21.1--- a/lisp/prelude.asd Fri Apr 19 22:00:00 2024 -0400
21.2+++ b/lisp/prelude.asd Sat Apr 20 22:14:30 2024 -0400
21.3@@ -1,3 +1,5 @@
21.4+(pushnew :prelude *features*)
21.5+(pushnew "PRELUDE" *modules* :test 'equal)
21.6 (defsystem :prelude
21.7 :depends-on (:std :dat :cli :doc
21.8 :io :gui :log :net
21.9@@ -7,7 +9,8 @@
21.10 :app :rocksdb :btrfs :uring
21.11 :tree-sitter :xkb :ssh2 :sndfile ;; magick
21.12 :zstd :uring :blake3 :ublk
21.13- :nuklear :aud)
21.14-
21.15+ :nuklear :aud :cry :krypt)
21.16 :build-operation monolithic-compile-bundle-op
21.17 :build-pathname "prelude")
21.18+
21.19+
22.1--- a/lisp/std/file.lisp Fri Apr 19 22:00:00 2024 -0400
22.2+++ b/lisp/std/file.lisp Sat Apr 20 22:14:30 2024 -0400
22.3@@ -361,8 +361,15 @@
22.4 (with-input-from-file (in file :element-type element-type)
22.5 (file-length in)))
22.6
22.7+(defun file-timestamp ()
22.8+ "Returns current timestamp as a string suitable as the name of a timestamped-file."
22.9+ (multiple-value-bind (sec min hr day mon yr)
22.10+ (get-decoded-time)
22.11+ (format nil "~4d~2,'0d~2,'0d_~2,'0d~2,'0d~2,'0d" yr mon day hr min sec)))
22.12+
22.13 (defun file-date ()
22.14 "Returns current date as a string suitable as the name of a timestamped-file."
22.15 (multiple-value-bind (sec min hr day mon yr)
22.16 (get-decoded-time)
22.17- (format nil "~4d~2d~2d_~2d~2d~2d" yr mon day hr min sec)))
22.18+ (declare (ignore sec min hr))
22.19+ (format nil "~4d~2,'0d~2,'0d" yr mon day)))
23.1--- a/lisp/std/pkg.lisp Fri Apr 19 22:00:00 2024 -0400
23.2+++ b/lisp/std/pkg.lisp Sat Apr 20 22:14:30 2024 -0400
23.3@@ -1,3 +1,5 @@
23.4+(pushnew :std *features*)
23.5+(pushnew "STD" *modules* :test 'equal)
23.6 (uiop:define-package :std
23.7 (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien)
23.8 (:use-reexport :std/named-readtables)
23.9@@ -49,6 +51,14 @@
23.10 :decode-float64
23.11 ;; stream
23.12 :copy-stream
23.13+ :wrapped-stream
23.14+ :wrapped-character-input-stream
23.15+ :wrapped-character-output-stream
23.16+ :counting-character-input-stream
23.17+ :prefixed-character-output-stream
23.18+ :stream-of :char-count-of :line-count-of :col-count-of
23.19+ :prev-col-count-of :col-index-of :write-prefix
23.20+ :prefix-of
23.21 ;; path
23.22 #:wild-pathname
23.23 #:non-wild-pathname
23.24@@ -67,6 +77,7 @@
23.25 :+pathsep+
23.26 :octet-vector=
23.27 :file-date
23.28+ :file-timestamp
23.29 ;; string
23.30 :*omit-nulls*
23.31 :*whitespaces*
23.32@@ -109,9 +120,11 @@
23.33 :timed-join-thread :kill-thread :hang
23.34 :thread-count :dump-thread
23.35 :make-oracle :make-supervisor :oracle :run-task
23.36+ :oracle-id
23.37 :push-job :push-task :push-worker :push-result
23.38 :run-job :run-stage
23.39 :pop-job :pop-task :pop-worker :pop-result
23.40+ :make-task-pool
23.41 :start-task-pool :pause-task-pool :shutdown-task-pool
23.42 :push-stage :designate-oracle :make-task-pool
23.43 :task :job :task-pool :stage :task-pool-p
24.1--- a/lisp/std/stream.lisp Fri Apr 19 22:00:00 2024 -0400
24.2+++ b/lisp/std/stream.lisp Sat Apr 20 22:14:30 2024 -0400
24.3@@ -48,3 +48,127 @@
24.4 (when finish-output
24.5 (finish-output output))
24.6 output-position))
24.7+
24.8+;; from SBCL manual
24.9+(defclass wrapped-stream (fundamental-stream)
24.10+ ((stream :initarg :stream :reader stream-of)))
24.11+
24.12+(defmethod stream-element-type ((stream wrapped-stream))
24.13+ (stream-element-type (stream-of stream)))
24.14+
24.15+(defmethod close ((stream wrapped-stream) &key abort)
24.16+ (close (stream-of stream) :abort abort))
24.17+
24.18+(defclass wrapped-character-input-stream (wrapped-stream fundamental-character-input-stream)
24.19+ ())
24.20+
24.21+(defmethod stream-read-char ((stream wrapped-character-input-stream))
24.22+ (read-char (stream-of stream) nil :eof))
24.23+
24.24+(defmethod stream-unread-char ((stream wrapped-character-input-stream)
24.25+ char)
24.26+ (unread-char char (stream-of stream)))
24.27+
24.28+#| example:
24.29+(with-input-from-string (input "1 2
24.30+ 3 :foo ")
24.31+ (let ((counted-stream (make-instance 'counting-character-input-stream
24.32+ :stream input)))
24.33+ (loop for thing = (read counted-stream) while thing
24.34+ unless (numberp thing) do
24.35+ (error "Non-number ~S (line ~D, column ~D)" thing
24.36+ (line-count-of counted-stream)
24.37+ (- (col-count-of counted-stream)
24.38+ (length (format nil "~S" thing))))
24.39+ end
24.40+ do (print thing))))
24.41+1
24.42+2
24.43+3
24.44+Non-number :FOO (line 2, column 5)
24.45+ [Condition of type SIMPLE-ERROR]
24.46+|#
24.47+(defclass counting-character-input-stream
24.48+ (wrapped-character-input-stream)
24.49+ ((char-count :initform 1 :accessor char-count-of)
24.50+ (line-count :initform 1 :accessor line-count-of)
24.51+ (col-count :initform 1 :accessor col-count-of)
24.52+ (prev-col-count :initform 1 :accessor prev-col-count-of)))
24.53+
24.54+(defmethod stream-read-char ((stream counting-character-input-stream))
24.55+ (with-accessors ((inner-stream stream-of) (chars char-count-of)
24.56+ (lines line-count-of) (cols col-count-of)
24.57+ (prev prev-col-count-of)) stream
24.58+ (let ((char (call-next-method)))
24.59+ (cond ((eql char :eof)
24.60+ :eof)
24.61+ ((char= char #\Newline)
24.62+ (incf lines)
24.63+ (incf chars)
24.64+ (setf prev cols)
24.65+ (setf cols 1)
24.66+ char)
24.67+ (t
24.68+ (incf chars)
24.69+ (incf cols)
24.70+ char)))))
24.71+
24.72+(defmethod stream-unread-char ((stream counting-character-input-stream)
24.73+ char)
24.74+ (with-accessors ((inner-stream stream-of) (chars char-count-of)
24.75+ (lines line-count-of) (cols col-count-of)
24.76+ (prev prev-col-count-of)) stream
24.77+ (cond ((char= char #\Newline)
24.78+ (decf lines)
24.79+ (decf chars)
24.80+ (setf cols prev))
24.81+ (t
24.82+ (decf chars)
24.83+ (decf cols)
24.84+ char))
24.85+ (call-next-method)))
24.86+
24.87+(defclass wrapped-character-output-stream (wrapped-stream fundamental-character-output-stream)
24.88+ ((col-index :initform 0 :accessor col-index-of)))
24.89+
24.90+(defmethod stream-line-column ((stream wrapped-character-output-stream))
24.91+ (col-index-of stream))
24.92+
24.93+(defmethod stream-write-char ((stream wrapped-character-output-stream)
24.94+ char)
24.95+ (with-accessors ((inner-stream stream-of) (cols col-index-of)) stream
24.96+ (write-char char inner-stream)
24.97+ (if (char= char #\Newline)
24.98+ (setf cols 0)
24.99+ (incf cols))))
24.100+
24.101+#| example:
24.102+(flet ((format-timestamp (stream)
24.103+ (apply #'format stream "[~2@*~2,' D:~1@*~2,'0D:~0@*~2,'0D] "
24.104+ (multiple-value-list (get-decoded-time)))))
24.105+ (let ((output (make-instance 'prefixed-character-output-stream
24.106+ :stream *standard-output*
24.107+ :prefix #'format-timestamp)))
24.108+ (loop for string in '("abc" "def" "ghi") do
24.109+ (write-line string output)
24.110+ (sleep 1))))
24.111+[ 0:30:05] abc
24.112+[ 0:30:06] def
24.113+[ 0:30:07] ghi
24.114+NIL
24.115+|#
24.116+(defclass prefixed-character-output-stream
24.117+ (wrapped-character-output-stream)
24.118+ ((prefix :initarg :prefix :reader prefix-of)))
24.119+
24.120+(defgeneric write-prefix (prefix stream)
24.121+ (:method ((prefix string) stream) (write-string prefix stream))
24.122+ (:method ((prefix function) stream) (funcall prefix stream)))
24.123+
24.124+(defmethod stream-write-char ((stream prefixed-character-output-stream)
24.125+ char)
24.126+ (with-accessors ((inner-stream stream-of) (cols col-index-of)
24.127+ (prefix prefix-of)) stream
24.128+ (when (zerop cols)
24.129+ (write-prefix prefix inner-stream))
24.130+ (call-next-method)))
25.1--- a/lisp/std/tests.lisp Fri Apr 19 22:00:00 2024 -0400
25.2+++ b/lisp/std/tests.lisp Sat Apr 20 22:14:30 2024 -0400
25.3@@ -13,9 +13,8 @@
25.4 (defsuite :std)
25.5 (in-suite :std)
25.6 (in-readtable :std)
25.7-
25.8 ;; prevent threadlocks
25.9-(setf sb-unix::*on-dangerous-wait* :error)
25.10+;; (setf sb-unix::*on-dangerous-wait* :error)
25.11
25.12 (deftest readtables ()
25.13 "Test :std readtable"
25.14@@ -144,6 +143,10 @@
25.15 (sleep 0.1)
25.16 (is (/= (ttl) 2.0))))
25.17
25.18+(deftest tasks ()
25.19+ "Test task-pools, oracles, and workers."
25.20+ (let ((pool1 (make-task-pool)))))
25.21+
25.22 (deftest fmt ()
25.23 "Test standard formatters"
25.24 (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3))))
25.25@@ -239,15 +242,15 @@
25.26 x) ;; 2
25.27 '(42 42 2)))))
25.28
25.29-(eval-always
25.30- (define-bitfield testbits
25.31- (a boolean)
25.32- (b (signed-byte 2))
25.33- (c (unsigned-byte 3) :initform 1)
25.34- (d (integer -100 100))
25.35- (e (member foo bar baz))))
25.36
25.37-(deftest bits ()
25.38+(deftest bits (:disabled t)
25.39+ (eval-always
25.40+ (define-bitfield testbits
25.41+ (a boolean)
25.42+ (b (signed-byte 2))
25.43+ (c (unsigned-byte 3) :initform 1)
25.44+ (d (integer -100 100))
25.45+ (e (member foo bar baz))))
25.46 (let ((bits (make-testbits)))
25.47 (is (not (testbits-a bits)))
25.48 (is (= 0 (testbits-b bits)))
26.1--- a/lisp/std/thread.lisp Fri Apr 19 22:00:00 2024 -0400
26.2+++ b/lisp/std/thread.lisp Sat Apr 20 22:14:30 2024 -0400
26.3@@ -151,13 +151,20 @@
26.4 ;; 0,-1,-2
26.5 ;; (multiple-value-list (sb-unix:unix-getrusage 0))
26.6 ;; (setf sb-unix::*on-dangerous-wait* :error)
26.7+(defvar *oracle-threads* nil)
26.8
26.9-(defclass oracle ()
26.10- ((thread :initarg :thread :accessor oracle-thread)))
26.11+(defun find-oracle (id)
26.12+ (declare ((unsigned-byte 32) id))
26.13+ (find id *oracle-threads* :test '= :key 'oracle-id))
26.14
26.15-(defgeneric make-oracle (thread)
26.16- (:method ((thread thread))
26.17- (make-instance 'oracle :thread thread)))
26.18+(defstruct (oracle (:constructor %make-oracle (id thread)))
26.19+ (id 0 :type (unsigned-byte 32) :read-only t)
26.20+ (thread *current-thread* :read-only t))
26.21+
26.22+(defun make-oracle (thread)
26.23+ (let ((orc (%make-oracle (sb-thread:thread-os-tid thread) thread)))
26.24+ (prog1 orc
26.25+ (pushnew orc *oracle-threads* :test '= :key #'oracle-id))))
26.26
26.27 (defgeneric designate-oracle (host guest))
26.28
26.29@@ -166,11 +173,13 @@
26.30 (defgeneric push-result (task pool))
26.31 (defgeneric push-worker (thread pool))
26.32 (defgeneric push-stage (stage pool))
26.33+
26.34 (defgeneric pop-job (pool))
26.35 (defgeneric pop-task (pool))
26.36 (defgeneric pop-result (pool))
26.37 (defgeneric pop-worker (pool))
26.38 (defgeneric pop-stage (pool))
26.39+
26.40 (defgeneric start-task-pool (pool))
26.41 (defgeneric pause-task-pool (pool))
26.42 (defgeneric stop-task-pool (pool))
26.43@@ -180,21 +189,21 @@
26.44 (defgeneric run-task (self task))
26.45
26.46 (defstruct task-pool
26.47- (oracle nil :type (or null oracle))
26.48+ (oracle-id nil :type (or null (unsigned-byte 32)))
26.49 (jobs (sb-concurrency:make-queue :name "jobs"))
26.50 (stages (make-array 0 :element-type 'stage :fill-pointer 0) :type (array stage *))
26.51 (workers (make-array 0 :element-type 'thread :fill-pointer 0) :type (array thread *))
26.52 (results (sb-concurrency:make-queue :name "results")))
26.53
26.54-(defmethod designate-oracle ((self task-pool) (guest oracle))
26.55- (setf (task-pool-oracle self) guest)
26.56+(defmethod designate-oracle ((self task-pool) (guest integer))
26.57+ (setf (task-pool-oracle-id self) guest)
26.58 self)
26.59
26.60 (defmethod designate-oracle ((self task-pool) (guest thread))
26.61 (designate-oracle self (make-oracle guest)))
26.62
26.63-(defmethod oracle-thread ((self task-pool))
26.64- (oracle-thread (task-pool-oracle self)))
26.65+(defmethod task-pool-oracle ((self task-pool))
26.66+ (oracle-thread (find-oracle (slot-value self 'oracle))))
26.67
26.68 (defmethod push-worker ((worker thread) (pool task-pool))
26.69 (vector-push worker (task-pool-workers pool)))
27.1--- a/skelfile Fri Apr 19 22:00:00 2024 -0400
27.2+++ b/skelfile Sat Apr 20 22:14:30 2024 -0400
27.3@@ -14,4 +14,4 @@
27.4 (clean () #$rm -rf .stash$#
27.5 #$cd rust && cargo clean$#
27.6 #$cd emacs && rm -rf */*.elc$#
27.7- #$cd lisp && rm -rf */*.fasl$#))
27.8+ #$find lisp -name '*.fasl' -type f -delete$#))
28.1--- a/x.lisp Fri Apr 19 22:00:00 2024 -0400
28.2+++ b/x.lisp Sat Apr 20 22:14:30 2024 -0400
28.3@@ -15,6 +15,9 @@
28.4 (require 'sb-grovel)
28.5 (require 'sb-cltl2)
28.6
28.7+#-(or sbcl cl) (error "unsupported Lisp compiler")
28.8+(sb-ext:enable-debugger)
28.9+
28.10 #-quicklisp
28.11 (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname))))
28.12 (when (probe-file quicklisp-init)
28.13@@ -30,7 +33,8 @@
28.14
28.15 (defpackage :x
28.16 (:use :cl :std :std/named-readtables)
28.17- (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*app-path* :*bin-path*))
28.18+ (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*app-path* :*bin-path*
28.19+ :*compression-level*))
28.20
28.21 (in-package :x)
28.22
28.23@@ -44,6 +48,8 @@
28.24 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
28.25 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*))
28.26
28.27+(defvar *compression-level* nil)
28.28+
28.29 (push *core-path* asdf:*central-registry*)
28.30 (push *lisp-path* ql:*local-project-directories*)
28.31 (push *lib-path* ql:*local-project-directories*)
28.32@@ -71,20 +77,18 @@
28.33 (defun done () (print :OK))
28.34
28.35 (defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
28.36- (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression t))
28.37+ (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*))
28.38
28.39 (defun compile-std (&optional force save)
28.40- (sb-ext:enable-debugger)
28.41 (asdf:compile-system :std :force force)
28.42 (asdf:load-system :std :force force)
28.43- (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression nil)))
28.44+ (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*)))
28.45
28.46 (defun compile-prelude (&optional force save)
28.47 ;; (compile-std)
28.48- (sb-ext:enable-debugger)
28.49 (asdf:compile-system :prelude :force force)
28.50 ;; (rocksdb:load-rocksdb save)
28.51- (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression 19)))
28.52+ (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*)))
28.53
28.54 (defun save-foreign (name exports &rest args)
28.55 (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
28.56@@ -93,7 +97,7 @@
28.57 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
28.58
28.59 (defvar *thunk* nil)
28.60-#-(or sbcl cl) (error "unsupported Lisp compiler")
28.61+
28.62 (setq *print-level* 32
28.63 *print-length* 64)
28.64 ;; collect args from shell
28.65@@ -103,9 +107,10 @@
28.66 (help "x --- core build tool
28.67 x.lisp [CMD]
28.68 CMDS:
28.69+test
28.70+compile
28.71 build
28.72 run
28.73-test
28.74 save
28.75 install")))
28.76
28.77@@ -136,6 +141,13 @@
28.78
28.79 ;; (defun parse-arg (arg))
28.80
28.81+(defun x-compile (args)
28.82+ (if args
28.83+ (let ((name (car args)))
28.84+ (ql:quickload name)
28.85+ (asdf:compile-system name :force t))
28.86+ (compile-prelude t nil)))
28.87+
28.88 (defun x-build (args)
28.89 (if args
28.90 (let ((name (car args)))
28.91@@ -146,6 +158,16 @@
28.92 (asdf:make sys)))
28.93 (bail "missing arg")))
28.94
28.95+(defun x-save (args)
28.96+ (if args
28.97+ (let ((name (car args)))
28.98+ (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
28.99+ (string-case (name)
28.100+ ("prelude" (compile-prelude t t))
28.101+ ("std" (compile-std t t))))
28.102+ ;; self save
28.103+ (sb-ext:run-program "x.lisp" nil :input t :output t)))
28.104+
28.105 (defun x-test (args)
28.106 (if args
28.107 (let ((name (car args)))
28.108@@ -187,6 +209,7 @@
28.109 (sb-impl::toplevel-repl nil))
28.110 (let ((cmd (pop *args*)))
28.111 (cond
28.112+ ((equal cmd "compile") (setq *thunk* #'x-compile))
28.113 ((equal cmd "build") (setq *thunk* #'x-build))
28.114 ((equal cmd "run") (setq *thunk* #'x-run))
28.115 ((equal cmd "test") (setq *thunk* #'x-test))
28.116@@ -202,29 +225,11 @@
28.117 (log:debug! "running command" *thunk* *args*)
28.118 (funcall *thunk* *args*)))
28.119
28.120-(defun x-save (&optional args)
28.121- (if args
28.122- (let ((name (car args)))
28.123- (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
28.124- (string-case (name)
28.125- ("prelude" (compile-prelude t t))
28.126- ("std" (compile-std t t))))
28.127- ;; self save
28.128- (progn
28.129- (format t "saving self to ./x~%")
28.130- (eval
28.131- (read-from-string
28.132- (with-open-file (f (merge-pathnames "x.lisp" *core-path*))
28.133- ;; skip shebang
28.134- (read-line f t)
28.135- (with-output-to-string (s)
28.136- (copy-stream f s)))
28.137- nil))
28.138- (sb-ext:save-lisp-and-die "x"
28.139- :toplevel #'x-init
28.140- ;; :callable-exports '("compile_std" "compile_prelude")
28.141- :purify t
28.142- :executable t
28.143- :save-runtime-options t))))
28.144-
28.145-(x-save)
28.146+(format t "saving self to ./x~%")
28.147+(sb-ext:save-lisp-and-die
28.148+ "x"
28.149+ :toplevel #'x-init
28.150+ ;; :callable-exports '("compile_std" "compile_prelude")
28.151+ :purify t
28.152+ :executable t
28.153+ :save-runtime-options t)
