1.1--- a/.hgignore Tue Apr 16 21:52:55 2024 -0400
1.2+++ b/.hgignore Wed Apr 17 22:53:44 2024 -0400
1.3@@ -8,5 +8,6 @@
1.4 .*[.]dll$
1.5 .*[.]a$
1.6 .*[.]core$
1.7+.*[.]elc$
1.8 c/.*
1.9 [.]stash/.*
1.10\ No newline at end of file
2.1--- a/emacs/ellis.el Tue Apr 16 21:52:55 2024 -0400
2.2+++ b/emacs/ellis.el Wed Apr 17 22:53:44 2024 -0400
2.3@@ -48,6 +48,8 @@
2.4 (find-file file)))
2.5
2.6 (keymap-set user-map "e c" #'edit-emacs-config)
2.7+(keymap-set emacs-lisp-mode-map "C-c C-l" #'load-file)
2.8+(keymap-set emacs-lisp-mode-map "C-c M-k" #'elisp-byte-compile-file)
2.9
2.10 ;; (add-hook 'common-lisp-mode-hook #'enable-paredit-mode)
2.11 ;; (add-hook 'emacs-lisp-mode-hook #'enable-paredit-mode)
2.12@@ -227,6 +229,8 @@
2.13 "#+end_src" n>)
2.14 "org:src"))
2.15 ;;; Org Config
2.16+(keymap-set user-map "t" #'org-todo)
2.17+
2.18 ;; populate org-babel
2.19 (org-babel-do-load-languages
2.20 ;; TODO 2021-10-24: bqn, apl, k
3.1--- a/lisp/app/bin/bin.asd Tue Apr 16 21:52:55 2024 -0400
3.2+++ b/lisp/app/bin/bin.asd Wed Apr 17 22:53:44 2024 -0400
3.3@@ -1,7 +1,3 @@
3.4-#+sb-core-compression
3.5-(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
3.6- (uiop:dump-image (asdf:output-file o c) :executable t :compression t))
3.7-
3.8 (defsystem :bin
3.9 :depends-on (:bin/organ :bin/homer :bin/rdb :bin/skel :bin/packy)
3.10 :in-order-to ((test-op (test-op "app/tests")))
4.1--- a/lisp/ffi/rocksdb/macs.lisp Tue Apr 16 21:52:55 2024 -0400
4.2+++ b/lisp/ffi/rocksdb/macs.lisp Wed Apr 17 22:53:44 2024 -0400
4.3@@ -36,8 +36,8 @@
4.4 `(progn
4.5 (define-alien-routine ,s-fn void
4.6 (opt (* ,opt))
4.7- (val unsigned-char))
4.8- (define-alien-routine ,g-fn unsigned-char
4.9+ (val boolean))
4.10+ (define-alien-routine ,g-fn boolean
4.11 (opt (* ,opt)))
4.12 (export '(,g-fn ,s-fn) :rocksdb)))))
4.13
5.1--- a/lisp/ffi/rocksdb/opts.lisp Tue Apr 16 21:52:55 2024 -0400
5.2+++ b/lisp/ffi/rocksdb/opts.lisp Wed Apr 17 22:53:44 2024 -0400
5.3@@ -7,17 +7,17 @@
5.4
5.5 (define-opt rocksdb-ingestexternalfileoptions)
5.6 (define-alien-routine rocksdb-ingestexternalfileoptions-set-move-files void
5.7- (val unsigned-char))
5.8+ (val boolean))
5.9 (define-alien-routine rocksdb-ingestexternalfileoptions-set-snapshot-consistency void
5.10- (val unsigned-char))
5.11+ (val boolean))
5.12 (define-alien-routine rocksdb-ingestexternalfileoptions-set-allow-global-seqno void
5.13- (val unsigned-char))
5.14+ (val boolean))
5.15 (define-alien-routine rocksdb-ingestexternalfileoptions-set-allow-blocking-flush void
5.16- (val unsigned-char))
5.17+ (val boolean))
5.18 (define-alien-routine rocksdb-ingestexternalfileoptions-set-ingest-behind void
5.19- (val unsigned-char))
5.20+ (val boolean))
5.21 (define-alien-routine rocksdb-ingestexternalfileoptions-set-fail-if-not-bottommost-level void
5.22- (val unsigned-char))
5.23+ (val boolean))
5.24 (export '(rocksdb-ingestexternalfileoptions-set-move-files
5.25 rocksdb-ingestexternalfileoptions-set-snapshot-consistency
5.26 rocksdb-ingestexternalfileoptions-set-allow-global-seqno
5.27@@ -29,7 +29,7 @@
5.28 (define-alien-routine rocksdb-backup-engine-options-set-backup-dir void
5.29 (opts (* rocksdb-backup-engine-options)) (backup-dir c-string))
5.30 (define-alien-routine rocksdb-backup-engine-options-set-env void
5.31- (opts (* rocksdb-backup-engine-options)) (val unsigned-char))
5.32+ (opts (* rocksdb-backup-engine-options)) (val boolean))
5.33 (define-opt-accessor rocksdb-backup-engine-options share-table-files)
5.34 (define-opt-accessor rocksdb-backup-engine-options sync)
5.35 (define-opt-accessor rocksdb-backup-engine-options destroy-old-data)
5.36@@ -165,19 +165,19 @@
5.37 (define-opt-accessor rocksdb-options use-direct-reads)
5.38 (define-opt-accessor rocksdb-options use-direct-io-for-flush-and-compaction)
5.39 (define-opt-accessor rocksdb-options is-fd-close-on-exec)
5.40+(define-opt-accessor rocksdb-options inplace-update-num-locks size-t)
5.41 (define-opt-accessor rocksdb-options inplace-update-support)
5.42 (define-opt-accessor rocksdb-options advise-random-on-open)
5.43 (define-opt-accessor rocksdb-options atomic-flush)
5.44 (define-opt-accessor rocksdb-options manual-wal-flush)
5.45 (define-opt-accessor rocksdb-options avoid-unnecessary-blocking-io)
5.46-
5.47+(define-opt-accessor rocksdb-options writable-file-max-buffer-size (unsigned 64))
5.48 (define-opt-accessor rocksdb-options info-log-level int)
5.49 (define-opt-accessor rocksdb-options write-buffer-size size-t)
5.50 (define-opt-accessor rocksdb-options db-write-buffer-size size-t)
5.51 (define-opt-accessor rocksdb-options max-open-files int)
5.52 (define-opt-accessor rocksdb-options max-file-opening-threads int)
5.53 (define-opt-accessor rocksdb-options max-total-wal-size unsigned-long)
5.54-;; (define-opt-accessor rocksdb-options compression-options (a int)(b int) (c int) (d int))
5.55 (define-opt-accessor rocksdb-options compression-options-zstd-max-train-bytes int)
5.56 (define-opt-accessor rocksdb-options compression-options-max-dict-buffer-bytes unsigned-long)
5.57 (define-opt-accessor rocksdb-options num-levels int)
5.58@@ -188,8 +188,11 @@
5.59 (define-opt-accessor rocksdb-options target-file-size-multiplier int)
5.60 (define-opt-accessor rocksdb-options max-bytes-for-level-base unsigned-long)
5.61 (define-opt-accessor rocksdb-options max-bytes-for-level-multiplier double)
5.62-;; note: there is no rocksdb-options-get-block-based-table-factory
5.63-;; (define-opt-accessor rocksdb-options block-based-table-factory (* rocksdb-block-based-table-options))
5.64+
5.65+(define-alien-routine rocksdb-options-set-compression-options void
5.66+ (opt (* rocksdb-options))
5.67+ (a int) (b int) (c int) (d int))
5.68+
5.69 (define-alien-routine rocksdb-option-set-block-based-table-factory void
5.70 (opt (* rocksdb-options)) (table-opts (* rocksdb-block-based-table-options)))
5.71
5.72@@ -223,7 +226,9 @@
5.73 (define-opt-accessor rocksdb-options max-manifest-file-size size-t)
5.74 (define-opt-accessor rocksdb-options table-cache-numshardbits int)
5.75 (define-opt-accessor rocksdb-options arena-block-size size-t)
5.76-(define-opt-accessor rocksdb-options use-fsync int)
5.77+;; TODO 2024-04-17:
5.78+;; may need to be an int -- check src
5.79+(define-opt-accessor rocksdb-options use-fsync boolean)
5.80 (define-opt-accessor rocksdb-options db-log-dir c-string)
5.81 (define-opt-accessor rocksdb-options wal-dir c-string)
5.82 (define-opt-accessor rocksdb-options wal-ttl-seconds unsigned-long)
5.83@@ -233,22 +238,22 @@
5.84 (define-opt-accessor rocksdb-options stats-persist-period-sec unsigned-int)
5.85
5.86 (define-opt-accessor rocksdb-options access-hint-on-compaction-start int)
5.87-(define-opt-accessor rocksdb-options use-adaptive-mutex unsigned-char)
5.88+(define-opt-accessor rocksdb-options use-adaptive-mutex)
5.89 (define-opt-accessor rocksdb-options bytes-per-sync unsigned-long)
5.90 (define-opt-accessor rocksdb-options wal-bytes-per-sync unsigned-long)
5.91 (define-opt-accessor rocksdb-options file-max-buffer-size unsigned-long)
5.92 (define-opt-accessor rocksdb-options allow-concurrent-memtable-write)
5.93 (define-opt-accessor rocksdb-options enable-write-thread-adaptive-yield)
5.94 (define-opt-accessor rocksdb-options max-sequential-skip-in-iterations unsigned-long)
5.95-(define-opt-accessor rocksdb-options disable-auto-compaction int)
5.96-(define-opt-accessor rocksdb-options optimize-filters-for-hits int)
5.97+(define-opt-accessor rocksdb-options disable-auto-compactions)
5.98+(define-opt-accessor rocksdb-options optimize-filters-for-hits)
5.99 (define-opt-accessor rocksdb-options delete-obsolete-files-period-micros unsigned-long)
5.100-(define-opt-accessor rocksdb-options memtable-prefix-bloom-size-ration double)
5.101+(define-opt-accessor rocksdb-options memtable-prefix-bloom-size-ratio double)
5.102 (define-opt-accessor rocksdb-options max-compaction-bytes unsigned-long)
5.103 (define-opt-accessor rocksdb-options memtable-huge-page-size size-t)
5.104 (define-opt-accessor rocksdb-options max-successive-merges size-t)
5.105 (define-opt-accessor rocksdb-options bloom-locality unsigned-int)
5.106-(define-opt-accessor rocksdb-options report-bg-io-stats int)
5.107+(define-opt-accessor rocksdb-options report-bg-io-stats)
5.108 (define-opt-accessor rocksdb-options experimental-mempurge-threshold double)
5.109 (define-opt-accessor rocksdb-options wal-recovery-mode int)
5.110 (define-opt-accessor rocksdb-options compression-options-parallel-threads int)
5.111@@ -257,15 +262,36 @@
5.112 (define-opt-accessor rocksdb-options compaction-style int)
5.113 (define-opt-accessor rocksdb-options wal-compression int)
5.114
5.115-;; (universal-compaction-options)
5.116-;; (ratelimiter)
5.117-;; (row-cache)
5.118 ;; (hash-link-list-rep)
5.119-;; (plain-table-factory
5.120 ;; (hash-skip-list-rep)
5.121-;; (prepare-for-bulk-load)
5.122 ;; (memtable-vector-rep)
5.123
5.124+(define-alien-routine rocksdb-options-set-row-cache void
5.125+ (opt (* rocksdb-options))
5.126+ (cache (* rocksdb-cache)))
5.127+
5.128+(define-alien-routine rocksdb-options-set-ratelimiter void
5.129+ (opt (* rocksdb-options))
5.130+ (limiter (* rocksdb-ratelimiter)))
5.131+
5.132+(define-alien-routine rocksdb-options-set-universal-compaction-options void
5.133+ (opt (* rocksdb-options))
5.134+ (opts (* rocksdb-universal-compaction-options)))
5.135+
5.136+(define-alien-routine rocksdb-options-set-min-level-to-compress void
5.137+ (opt (* rocksdb-options))
5.138+ (level int))
5.139+
5.140+(define-alien-routine rocksdb-options-set-plain-table-factory void
5.141+ (opt (* rocksdb-options))
5.142+ (i int)
5.143+ (d double)
5.144+ (s1 size-t)
5.145+ (s2 size-t)
5.146+ (c char)
5.147+ (f1 unsigned-char)
5.148+ (f2 unsigned-char))
5.149+
5.150 (define-alien-routine rocksdb-options-prepare-for-bulk-load void
5.151 (opts (* rocksdb-options)))
5.152
5.153@@ -323,7 +349,9 @@
5.154 rocksdb-options-set-db-paths rocksdb-options-set-cf-paths
5.155 rocksdb-options-set-env rocksdb-options-set-info-log
5.156 rocksdb-options-statistics-get-ticker-count rocksdb-options-statistics-get-histogram-data
5.157- rocksdb-options-prepare-for-bulk-load))
5.158+ rocksdb-options-set-plain-table-factory rocksdb-options-set-min-level-to-compress
5.159+ rocksdb-options-prepare-for-bulk-load rocksdb-options-set-universal-compaction-options
5.160+ rocksdb-options-set-ratelimiter rocksdb-options-set-row-cache))
5.161
5.162 ;;; RocksDB Write Options
5.163 (define-opt rocksdb-writeoptions)
5.164@@ -394,6 +422,7 @@
5.165 (src (* rocksdb-options)))
5.166
5.167 (export '(rocksdb-options-create-copy))
5.168+
5.169 ;;; Aliases
5.170 ;; some of the RocksDB options don't follow the standard naming
5.171 ;; convention of 'rocksdb-*-set-*' and 'rocksdb-*-get-*'. In order to
6.1--- a/lisp/ffi/rocksdb/vars.lisp Tue Apr 16 21:52:55 2024 -0400
6.2+++ b/lisp/ffi/rocksdb/vars.lisp Wed Apr 17 22:53:44 2024 -0400
6.3@@ -83,14 +83,23 @@
6.4 (lambda (x) (string-downcase (symbol-name x)))
6.5 '(create-if-missing create-missing-column-families error-if-exists
6.6 paranoid-checks info-log-level write-buffer-size db-write-buffer-size
6.7- max-open-files max-file-opening-threads max-total-wal-size compression-options
6.8+ max-open-files max-file-opening-threads max-total-wal-size
6.9 compression-options-zstd-max-train-bytes compression-options-max-dict-buffer-bytes
6.10 compression-options-parallel-threads compression-options-use-zstd-dict-trainer
6.11 num-levels level0-file-num-compaction-trigger level0-slowdown-writes-trigger
6.12 level0-stop-writes-trigger target-file-size-base target-file-size-multiplier
6.13 max-bytes-for-level-base level-compaction-dynamic-level-bytes max-bytes-for-level-multiplier
6.14 ;; block-based-table-factory ;; set-only
6.15+ ;; parallelism
6.16+ ;; compression-options
6.17 ;; merge-operator db-log-dir wal-dir wal-ttl-seconds wal-size-limit-mb
6.18+ ;; memtable-vector-rep prepare-for-bulk-load
6.19+ ;; hash-skip-list-rep
6.20+ ;; plain-table-factory
6.21+ ;; min-level-to-compress
6.22+ ;; universal-compaction-options
6.23+ ;; ratelimiter
6.24+ ;; row-cache
6.25 allow-ingest-behind statistics-level
6.26 skip-stats-update-on-db-open skip-checking-sst-file-sizes-on-db-open enable-blob-files
6.27 min-blob-size blob-file-size blob-compression-type enable-blob-gc blob-gc-age-cutoff
6.28@@ -101,17 +110,17 @@
6.29 log-file-time-to-roll keep-log-file-num recycle-log-file-num soft-pending-compaction-bytes-limit
6.30 hard-pending-compaction-bytes-limit max-manifest-file-size table-cache-numshardbits arena-block-size
6.31 use-fsync manifest-preallocation-size allow-mmap-reads
6.32- allow-mmap-write use-direct-reads use-direct-io-for-flush-compaction is-fd-close-on-exec
6.33- stats-dump-period-sec stas-persist-period-sec advise-random-on-open access-hint-on-compaction-start
6.34+ allow-mmap-writes use-direct-reads use-direct-io-for-flush-and-compaction is-fd-close-on-exec
6.35+ stats-dump-period-sec stats-persist-period-sec advise-random-on-open access-hint-on-compaction-start
6.36 use-adaptive-mutex bytes-per-sync wal-bytes-per-sync writable-file-max-buffer-size
6.37 allow-concurrent-memtable-write enable-write-thread-adaptive-yield max-sequential-skip-in-iterations
6.38 disable-auto-compactions optimize-filters-for-hits delete-obsolete-files-period-micros
6.39- prepare-for-bulk-load memtable-vector-rep memtable-prefix-bloom-size-ratio max-compaction-bytes
6.40- hash-skip-list-rep plain-table-factory min-level-to-compress memtable-huge-page-size
6.41+ memtable-prefix-bloom-size-ratio max-compaction-bytes
6.42+ memtable-huge-page-size
6.43 max-successive-merges bloom-locality inplace-update-support inplace-update-num-locks
6.44 report-bg-io-stats avoid-unnecessary-blocking-io experimental-mempurge-threshold
6.45- wal-recovery-mode compression bottommost-compression compaction-style universal-compaction-options
6.46- ratelimiter atomic-flush row-cache manual-wal-flush wal-compression
6.47+ wal-recovery-mode compression bottommost-compression compaction-style
6.48+ atomic-flush manual-wal-flush wal-compression
6.49 prepopulate-blob-cache))
6.50 "Provides early list of options for macros to populate.")
6.51
7.1--- a/lisp/lib/cli/tests.lisp Tue Apr 16 21:52:55 2024 -0400
7.2+++ b/lisp/lib/cli/tests.lisp Wed Apr 17 22:53:44 2024 -0400
7.3@@ -194,7 +194,7 @@
7.4 ;;(ansi-t05)
7.5 )
7.6
7.7-(deftest cli-prompt (:disabled t) ;; FIXME: hijacks io in slime
7.8+(deftest cli-prompt (:disabled nil) ;; FIXME: hijacks io in slime
7.9 "Test CLI prompts"
7.10 ;; TODO: needs to be compiled outside scope of test - contender for
7.11 ;; fixture API
8.1--- a/lisp/lib/dat/gif.lisp Tue Apr 16 21:52:55 2024 -0400
8.2+++ b/lisp/lib/dat/gif.lisp Wed Apr 17 22:53:44 2024 -0400
8.3@@ -0,0 +1,6 @@
8.4+;;; dat/gif.lisp --- Simple GIF encoding
8.5+
8.6+;;
8.7+
8.8+;;; Code:
8.9+(in-package :dat/gif)
9.1--- a/lisp/lib/dat/pkg.lisp Tue Apr 16 21:52:55 2024 -0400
9.2+++ b/lisp/lib/dat/pkg.lisp Wed Apr 17 22:53:44 2024 -0400
9.3@@ -175,8 +175,12 @@
9.4 :dark-module-p
9.5 :read-file-content))
9.6
9.7+(defpackage :dat/gif
9.8+ (:nicknames :gif)
9.9+ (:use :cl :std :dat/proto))
9.10+
9.11 (defpackage :dat/png
9.12- (:use :cl :std :dat/proto :dat/qrcode :png))
9.13+ (:use :cl :std :dat/proto :png))
9.14
9.15 (uiop:define-package :dat
9.16 (:use-reexport :dat/proto :dat/csv :dat/arff :dat/toml :dat/json :dat/sxp :dat/xml :dat/bencode
10.1--- a/lisp/lib/dat/toml.lisp Tue Apr 16 21:52:55 2024 -0400
10.2+++ b/lisp/lib/dat/toml.lisp Wed Apr 17 22:53:44 2024 -0400
10.3@@ -370,6 +370,5 @@
10.4 (mapcar (lambda (it) (serialize it style)) thing)
10.5 thing))
10.6
10.7-(defmethod serialize (thing (format (eql :toml)) &key (style :raw))
10.8- (declare (ignore style))
10.9+(defmethod serialize (thing (format (eql :toml)) &key)
10.10 thing)
11.1--- a/lisp/lib/obj/db/disk.lisp Tue Apr 16 21:52:55 2024 -0400
11.2+++ b/lisp/lib/obj/db/disk.lisp Wed Apr 17 22:53:44 2024 -0400
11.3@@ -90,8 +90,6 @@
11.4 ;; (collect-stats code)
11.5 (funcall (aref *readers* code) stream))
11.6
11.7-;;;
11.8-
11.9 (defconstant +sequence-length+ 2)
11.10 (eval-when (:compile-toplevel :load-toplevel :execute)
11.11 (defconstant +fixnum-length+ 4))
12.1--- a/lisp/lib/obj/db/io.lisp Tue Apr 16 21:52:55 2024 -0400
12.2+++ b/lisp/lib/obj/db/io.lisp Wed Apr 17 22:53:44 2024 -0400
12.3@@ -227,7 +227,7 @@
12.4 (declaim (inline read-ascii-string-optimized))
12.5 (defun read-ascii-string-optimized (length string stream)
12.6 (declare (type fixnum length)
12.7- ;; (optimize speed)
12.8+ (optimize (speed 3))
12.9 )
12.10 (sb-sys:with-pinned-objects (string)
12.11 (let ((sap (advance-input-stream length stream))
13.1--- a/lisp/lib/rdb/obj.lisp Tue Apr 16 21:52:55 2024 -0400
13.2+++ b/lisp/lib/rdb/obj.lisp Wed Apr 17 22:53:44 2024 -0400
13.3@@ -11,36 +11,27 @@
13.4 (defun %set-rocksdb-option (opt key val)
13.5 (funcall (rdb-opt-setter key) opt val))
13.6
13.7-#| special cases
13.8-WARNING: #<OPT-HANDLER-MISSING compression-options {101A423693}>
13.9-WARNING: #<OPT-HANDLER-MISSING allow-mmap-write {101A5F0C93}>
13.10-WARNING: #<OPT-HANDLER-MISSING use-direct-io-for-flush-compaction {101A5F1913}>
13.11-WARNING: #<OPT-HANDLER-MISSING stas-persist-period-sec {101A5F32C3}>
13.12-WARNING: #<OPT-HANDLER-MISSING writable-file-max-buffer-size {101A5F4523}>
13.13-WARNING: #<OPT-HANDLER-MISSING disable-auto-compactions {101A5F54E3}>
13.14-WARNING: #<OPT-HANDLER-MISSING prepare-for-bulk-load {101A5F62E3}>
13.15-WARNING: #<OPT-HANDLER-MISSING memtable-vector-rep {101A5F6DB3}>
13.16-WARNING: #<OPT-HANDLER-MISSING memtable-prefix-bloom-size-ratio {101A5F78B3}>
13.17-WARNING: #<OPT-HANDLER-MISSING hash-skip-list-rep {101A620573}>
13.18-WARNING: #<OPT-HANDLER-MISSING plain-table-factory {101A621083}>
13.19-WARNING: #<OPT-HANDLER-MISSING min-level-to-compress {101A621B53}>
13.20-WARNING: #<OPT-HANDLER-MISSING inplace-update-num-locks {101A6230F3}>
13.21-WARNING: #<OPT-HANDLER-MISSING universal-compaction-options {101A624CD3}>
13.22-WARNING: #<OPT-HANDLER-MISSING ratelimiter {101A625723}>
13.23-WARNING: #<OPT-HANDLER-MISSING row-cache {101A6262E3}>
13.24-|#
13.25-
13.26 (defun %get-rocksdb-option (opt key)
13.27 (if-let ((g (rdb-opt-getter key)))
13.28 (funcall g opt)
13.29 (warn 'opt-handler-missing :message key)))
13.30
13.31+(defun opt-no-setter-p (k)
13.32+ (let ((k (typecase k
13.33+ (string (string-downcase k))
13.34+ (symbol (string-downcase (symbol-name k)))
13.35+ (t (string-downcase (format nil "~s" k))))))
13.36+ (member t
13.37+ (mapcar (lambda (x) (equal k x)) (list "parallelism" "enable-statistics")))))
13.38+
13.39 (defclass rdb-opts ()
13.40 ((table :initarg :table :type hash-table :accessor rdb-opts-table)
13.41 (sap :initarg :sap :type (or null alien) :accessor rdb-opts-sap)))
13.42
13.43 (defmethod initialize-instance ((self rdb-opts) &rest initargs &key &allow-other-keys)
13.44 (with-slots (sap table) self
13.45+ ;; initialize slots - remember, initargs doesn't refer to slot
13.46+ ;; names, they're opt names.
13.47 (unless (getf initargs :table) (setf table (make-hash-table :test #'equal)))
13.48 (unless (getf initargs :sap) (setf sap (rocksdb-options-create)))
13.49 (loop for (k v) on initargs by #'cddr while v
13.50@@ -74,6 +65,8 @@
13.51 "Initialized the SAP slot with values from TABLE."
13.52 (with-slots (table) self
13.53 (loop for k in (hash-table-keys table)
13.54+ ;; note how we don't handle any special cases here - we can
13.55+ ;; always set an opt but sometimes we can't get it.
13.56 do (push-sap self k))))
13.57
13.58 (defmethod pull-sap ((self rdb-opts) key)
13.59@@ -82,7 +75,8 @@
13.60 (defmethod pull-sap* ((self rdb-opts))
13.61 (with-slots (table) self
13.62 (loop for k in (hash-table-keys table)
13.63- do (pull-sap self k))
13.64+ unless (opt-no-setter-p k)
13.65+ do (pull-sap self k))
13.66 table))
13.67
13.68 (defmethod backfill-opts ((self rdb-opts) &key full)
13.69@@ -92,13 +86,14 @@
13.70 just the keys currently present in TABLE."
13.71 (if full
13.72 (loop for k across *rocksdb-options*
13.73+ unless (opt-no-setter-p k)
13.74 do (pull-sap self k))
13.75 (pull-sap* self))
13.76 (rdb-opts-table self))
13.77
13.78 (defun default-rdb-opts ()
13.79- ;; TODO 2024-03-10: handle lisp->C types
13.80- (make-rdb-opts :create-if-missing 1))
13.81+ (make-rdb-opts :create-if-missing t :create-missing-column-families t
13.82+ :parallelism (num-cpus)))
13.83
13.84 (defclass rdb-kv ()
13.85 ((key :initarg :key :type octet-vector :accessor rdb-key)
13.86@@ -112,8 +107,56 @@
13.87 (defvar *default-rdb-kv* (make-kv #() #()))
13.88
13.89 ;;; iterator
13.90-(defstruct (rdb-iter (:constructor make-rdb-iter (&optional sap)))
13.91- (sap nil :type (or null alien)))
13.92+(defclass rdb-iter (sequence)
13.93+ ((sap :initform nil :initarg :sap :type (or null alien) :accessor rdb-iter-sap)))
13.94+
13.95+(defmethod iter-valid-p ((self rdb-iter))
13.96+ (rocksdb-iter-valid (rdb-iter-sap self)))
13.97+
13.98+(defmethod iter-seek-to-first ((self rdb-iter))
13.99+ (rocksdb-iter-seek-to-first (rdb-iter-sap self)))
13.100+
13.101+(defmethod iter-seek-to-last ((self rdb-iter))
13.102+ (rocksdb-iter-seek-to-last (rdb-iter-sap self)))
13.103+
13.104+(defmethod iter-seek-for-prev ((self rdb-iter) (key vector) &key)
13.105+ (rocksdb-iter-seek-for-prev (rdb-iter-sap self) key (length key)))
13.106+
13.107+(defmethod iter-seek ((self rdb-iter) (key simple-vector) &key)
13.108+ (rocksdb-iter-seek (rdb-iter-sap self) key (length key)))
13.109+
13.110+(defmethod iter-next ((self rdb-iter))
13.111+ (rocksdb-iter-next (log:info! (rdb-iter-sap self))))
13.112+
13.113+(defmethod iter-prev ((self rdb-iter))
13.114+ (rocksdb-iter-prev (rdb-iter-sap self)))
13.115+
13.116+(defmethod iter-key ((self rdb-iter))
13.117+ (with-alien ((klen size-t))
13.118+ (let ((key (rocksdb-iter-key (rdb-iter-sap self) (addr klen))))
13.119+ (let ((k (make-array klen :element-type 'octet)))
13.120+ (clone-octets-from-alien key k klen)
13.121+ (values
13.122+ k
13.123+ klen)))))
13.124+
13.125+(defmethod iter-val ((self rdb-iter))
13.126+ (with-alien ((vlen size-t))
13.127+ (let ((val (rocksdb-iter-value (rdb-iter-sap self) (addr vlen))))
13.128+ (let ((v (make-array vlen :element-type 'octet)))
13.129+ (clone-octets-from-alien val v vlen)
13.130+ (values
13.131+ v
13.132+ vlen)))))
13.133+
13.134+(defmethod iter-kv ((self rdb-iter))
13.135+ (make-kv (iter-key self) (iter-val self)))
13.136+
13.137+(defmethod iter-timestamp ((self rdb-iter))
13.138+ (with-alien ((tslen size-t))
13.139+ (values
13.140+ (rocksdb-iter-timestamp (rdb-iter-sap self) (addr tslen))
13.141+ tslen)))
13.142
13.143 ;;; column family
13.144 (defstruct (rdb-cf (:constructor make-rdb-cf (name &key #+nil kv sap)))
13.145@@ -258,6 +301,15 @@
13.146 (open-db obj))
13.147 obj))
13.148
13.149+(defmethod backfill-opts ((self rdb) &key full)
13.150+ (with-slots (opts) self
13.151+ (if full
13.152+ (loop for k across *rocksdb-options*
13.153+ unless (opt-no-setter-p k)
13.154+ do (pull-sap opts k))
13.155+ (pull-sap* opts))
13.156+ (rdb-opts-table opts)))
13.157+
13.158 (defmethod push-cf ((cf rdb-cf) (db rdb))
13.159 (vector-push cf (rdb-cfs db)))
13.160
13.161@@ -336,9 +388,9 @@
13.162
13.163 (defmethod create-iter ((self rdb) &optional cf (opts (rocksdb-readoptions-create)))
13.164 (unless-null-db () self
13.165- (make-rdb-iter (if cf
13.166- (create-cf-iter-raw db cf opts)
13.167- (create-iter-raw db opts)))))
13.168+ (make-instance 'rdb-iter :sap (if cf
13.169+ (create-cf-iter-raw db cf opts)
13.170+ (create-iter-raw db opts)))))
13.171
13.172 (defmethod print-stats ((self rdb) &optional stream)
13.173 (print (rocksdb-options-statistics-get-string (rdb-opts-sap (rdb-opts self))) stream))
13.174@@ -411,15 +463,18 @@
13.175 (defmethod insert-key ((self rdb) key (val string) &key cf)
13.176 (insert-key self key (string-to-octets val) :cf cf))
13.177
13.178-(defmethod insert-kv ((self rdb) (kv rdb-kv) &key cf)
13.179+(defmethod insert-kv ((self rdb) (kv rdb-kv) &key cf opts)
13.180 (if cf
13.181- (put-cf-raw (rdb-db self)
13.182- (rdb-cf-sap
13.183- (find cf (rdb-cfs self)
13.184- :key #'rdb-cf-name
13.185- :test #'string=))
13.186- (rdb-key kv)
13.187- (rdb-val kv))
13.188+ (let ((cf (etypecase cf
13.189+ (rdb-cf cf)
13.190+ (t (find cf (rdb-cfs self)
13.191+ :key #'rdb-cf-name
13.192+ :test #'string=)))))
13.193+ (put-cf-raw (rdb-db self)
13.194+ (rdb-cf-sap cf)
13.195+ (rdb-key kv)
13.196+ (rdb-val kv)
13.197+ opts))
13.198 (put-kv self kv)))
13.199
13.200 (defmethod get-key ((self rdb) (key string) &key (opts (rocksdb-readoptions-create)) cf)
14.1--- a/lisp/lib/rdb/pkg.lisp Tue Apr 16 21:52:55 2024 -0400
14.2+++ b/lisp/lib/rdb/pkg.lisp Wed Apr 17 22:53:44 2024 -0400
14.3@@ -65,7 +65,11 @@
14.4 :create-iter :iter-next
14.5 :iter-prev :iter-seek
14.6 :iter-key :iter-val
14.7- :iter-timestamp
14.8+ :iter-timestamp :iter-kv
14.9+ :iter-seek-to-first
14.10+ :iter-seek-to-last
14.11+ :iter-seek-for-prev
14.12+ :iter-valid-p
14.13 ;; sst
14.14 :sst-file
14.15 :sst-stream
14.16@@ -80,6 +84,7 @@
14.17 :rdb-level-metadata-p
14.18 :rdb-bytes :rdb-bytes-buffer :rdb-opts-sap
14.19 :make-key :make-kv :make-val :rdb-kv :rdb-key :rdb-val
14.20+ :rdb-kv
14.21 :rdb-opts :make-rdb-opts
14.22 :default-rdb-opts
14.23 :rdb-cf :make-rdb-cf :create-cf
15.1--- a/lisp/lib/rdb/proto.lisp Tue Apr 16 21:52:55 2024 -0400
15.2+++ b/lisp/lib/rdb/proto.lisp Wed Apr 17 22:53:44 2024 -0400
15.3@@ -90,8 +90,13 @@
15.4 (:documentation "Seek to a certain KEY in the iterator."))
15.5 (defgeneric iter-val (self)
15.6 (:documentation "Return the value of current iterator item."))
15.7+(defgeneric iter-valid-p (self)
15.8+ (:documentation "Return non-nil if the iterator cursor is valid."))
15.9 (defgeneric iter-key (self)
15.10 (:documentation "Return the key of current iterator item."))
15.11+(defgeneric iter-kv (self)
15.12+ (:documentation "Return the current KV object of the iterator by getting the key and
15.13+val."))
15.14 (defgeneric iter-timestamp (self)
15.15 (:documentation "Return the timestamp of current iterator item."))
15.16 (defgeneric make-val (val)
16.1--- a/lisp/lib/rdb/raw.lisp Tue Apr 16 21:52:55 2024 -0400
16.2+++ b/lisp/lib/rdb/raw.lisp Wed Apr 17 22:53:44 2024 -0400
16.3@@ -14,7 +14,7 @@
16.4
16.5 (defun default-rocksdb-options ()
16.6 (make-rocksdb-options
16.7- (lambda (o) (rocksdb-options-set-create-if-missing o 1))))
16.8+ (lambda (o) (rocksdb-options-set-create-if-missing o t))))
16.9
16.10 (defun get-stats-raw (opt htype)
16.11 (with-alien ((hist (* rocksdb-statistics-histogram-data) (rocksdb-statistics-histogram-data-create)))
17.1--- a/lisp/lib/rdb/tests.lisp Tue Apr 16 21:52:55 2024 -0400
17.2+++ b/lisp/lib/rdb/tests.lisp Wed Apr 17 22:53:44 2024 -0400
17.3@@ -24,13 +24,11 @@
17.4 ;; check defaults
17.5 (is (< 100 (hash-table-size (backfill-opts default))))
17.6 (is (typep (rdb-opts-sap default) '(alien (* rocksdb-options))))
17.7- (is (= 1 (get-opt default "create-if-missing")))
17.8- (is (= 1
17.9- (set-opt default "enable-blob-files" 1 :push t)
17.10- (get-opt default "enable-blob-files")
17.11- (rocksdb-options-get-enable-blob-files (rdb-opts-sap default))))
17.12- (is (= 0
17.13- (rocksdb-options-get-error-if-exists (rdb-opts-sap default))))))
17.14+ (is (eql t (get-opt default "create-if-missing")))
17.15+ (is (eql t (set-opt default "enable-blob-files" t :push t)))
17.16+ (is (eql t (get-opt default "enable-blob-files")))
17.17+ (is (eql t (rocksdb-options-get-enable-blob-files (rdb-opts-sap default))))
17.18+ (is (null (rocksdb-options-get-error-if-exists (rdb-opts-sap default))))))
17.19
17.20 (deftest raw ()
17.21 "Test the raw RocksDB function wrappers."
17.22@@ -58,6 +56,7 @@
17.23 "Test RDB struct and methods."
17.24 ;; NOTE: passing a directory with trailing slash causes segfault - guess we gotta handle tht
17.25 (with-db (db (debug! (create-db "/tmp/rdb" :open t)))
17.26+ (info! (hash-table-alist (backfill-opts db :full t)))
17.27 ;; get/set without cf
17.28 (put-kv-str-raw (rdb-db db) "key" "val")
17.29 (is (equal (get-kv-str-raw (rdb-db db) "key") "val"))
17.30@@ -69,7 +68,7 @@
17.31 (create-cfs db)
17.32 ;; TODO
17.33 (do-cfs (cf (rdb-cfs db))
17.34- (insert-kv db (make-kv "key" "val") :cf (rdb-cf-name cf))
17.35+ (insert-kv db (make-kv "key" "val") :cf cf)
17.36 (is (equal (get-key db "key" :cf (rdb-cf-sap cf)) "val")))
17.37 (rocksdb-cancel-all-background-work (rdb-db db) nil)
17.38 ;; insert after background cancel
17.39@@ -83,14 +82,22 @@
17.40 (with-temp-db (tmp (cf1 cf2 cf3 cf4) :destroy t)
17.41 (set-opt tmp :parallelism (num-cpus))
17.42 ;; https://github.com/facebook/rocksdb/wiki/unordered_write
17.43- (set-opt tmp :unordered-write 1)
17.44- (set-opt tmp :enable-statistics 1)
17.45+ (set-opt tmp :unordered-write t)
17.46+ (set-opt tmp :enable-statistics t)
17.47 (set-opt tmp :statistics-level (rocksdb-statistics-level "all"))
17.48 (push-opts tmp)
17.49 (open-db tmp)
17.50 (create-cfs tmp)
17.51 (with-iter (it (create-iter tmp))
17.52- (print it)
17.53+ (iter-seek-to-first it)
17.54+ (is (sequence:emptyp (iter-key it)))
17.55+ (is (sequence:emptyp (iter-val it)))
17.56+ (is (iter-valid-p it))
17.57+ (iter-seek-to-last it)
17.58+ (is (typep (iter-kv it) 'rdb-kv))
17.59+ (is (sequence:emptyp (iter-key it)))
17.60+ (is (sequence:emptyp (iter-val it)))
17.61+ ;; (info! (iter-next it))
17.62 (rocksdb-iter-destroy (rdb-iter-sap it)))
17.63 (dotimes (i 10000)
17.64 (insert-key tmp (format nil "foo~A" i) (format nil "bar~A" i)))
18.1--- a/lisp/lib/rt/pkg.lisp Tue Apr 16 21:52:55 2024 -0400
18.2+++ b/lisp/lib/rt/pkg.lisp Wed Apr 17 22:53:44 2024 -0400
18.3@@ -85,6 +85,7 @@
18.4 :pop-test
18.5 :delete-test
18.6 :find-test
18.7+ :find-suite
18.8 :do-suite
18.9 :test-object
18.10 :test
18.11@@ -93,11 +94,7 @@
18.12 :test-name
18.13 :tests
18.14 :test-form
18.15- :test-results
18.16- :enable-coverage
18.17- :disable-coverage
18.18- :with-coverage
18.19- :cover-report))
18.20+ :test-results))
18.21
18.22 (defpackage :rt/bench
18.23 (:nicknames :bench)
18.24@@ -111,8 +108,11 @@
18.25 (:nicknames :cover)
18.26 (:use :cl :std :log :rt :sb-cover)
18.27 (:reexport :sb-cover)
18.28- (:export :with-coverage :start-coverage :stop-coverage
18.29- :coverage-report :*coverage-directory*))
18.30+ (:reexport :sb-sprof)
18.31+ (:export
18.32+ :with-coverage :start-coverage :stop-coverage
18.33+ :*coverage-directory*
18.34+ :cover-report))
18.35
18.36 (defpackage :rt/tracing
18.37 (:nicknames :tracing)
18.38@@ -134,7 +134,7 @@
18.39 (in-readtable :std)
18.40
18.41 ;;; Vars
18.42-(defvar *test-opts* '(optimize sb-c::instrument-consing (debug 1)))
18.43+(defvar *test-opts* '(optimize sb-c::instrument-consing))
18.44 (defvar *compile-tests* t
18.45 "When nil do not compile tests. With a value of t, tests are compiled
18.46 with default optimizations else the value is used to configure
18.47@@ -168,6 +168,7 @@
18.48
18.49 ;; TODO
18.50 (defun do-tests-concurrently (&optional (suite *test-suite*) force (output *standard-output*))
18.51+ (declare (ignore suite force))
18.52 (sb-thread:with-mutex (*test-output-mutex*)
18.53 (let ((stream (make-synonym-stream output)))
18.54 (let ((*standard-output* stream)
18.55@@ -381,9 +382,6 @@
18.56 (test-args self)
18.57 (test-persist-p self))))
18.58
18.59-;; TODO 2023-09-01: use sxp?
18.60-;; (defun validate-form (form))
18.61-
18.62 (defmethod push-result ((self test-result) (place test))
18.63 (with-slots (results) place
18.64 (push self results)))
18.65@@ -392,7 +390,7 @@
18.66 (pop (test-results self)))
18.67
18.68 (defmethod eval-test ((self test))
18.69- `(progn ,@(test-form self)))
18.70+ (eval `(progn ,@(test-form self))))
18.71
18.72 (defmethod compile-test ((self test) &key declare &allow-other-keys)
18.73 (compile
18.74@@ -425,14 +423,14 @@
18.75 (if-let ((opt *compile-tests*))
18.76 ;; RESEARCH 2023-08-31: with-compilation-unit?
18.77 (progn
18.78- (if (eq opt t)
18.79+ (if (eq opt t)
18.80 (setq opt *test-opts*)
18.81 (setq opt (push *test-opts* opt)))
18.82 ;; TODO 2023-09-21: handle failures here
18.83- (funcall (compile-test self :declare opt))
18.84+ (ignore-some-conditions (style-warning) (funcall (compile-test self :declare opt)))
18.85 (setf %test-result (make-test-result :pass (test-fn self))))
18.86 (progn
18.87- (eval-test self)
18.88+ (ignore-some-conditions (style-warning) (eval-test self))
18.89 (setf %test-result (make-test-result :pass (test-name self)))))))
18.90 (if *catch-test-errors*
18.91 (handler-bind
18.92@@ -496,7 +494,11 @@
18.93
18.94 (deftype test-suite-designator ()
18.95 "Either nil, a symbol, a string, or a `test-suite' object."
18.96- '(or null symbol string test-suite test keyword))
18.97+ '(or null symbol string test-suite keyword))
18.98+
18.99+(defun find-suite (name)
18.100+ (declare (test-suite-designator name))
18.101+ (find name *test-suite-list* :test #'test-name=))
18.102
18.103 (defmethod map-tests ((self test-suite) function)
18.104 (mapcar function (tests self)))
18.105@@ -522,10 +524,21 @@
18.106 (defmethod do-test ((self test-suite) &optional test)
18.107 (push-result
18.108 (if test
18.109- (do-test (find-test self (test-name test)))
18.110+ (do-test
18.111+ (etypecase test
18.112+ (test test)
18.113+ (string (find-test self test))
18.114+ (symbol (find-test self (symbol-name test)))))
18.115 (do-test (pop-test self)))
18.116 self))
18.117
18.118+(defmethod do-test ((self simple-string) &optional test)
18.119+ (let ((suite (find-suite self)))
18.120+ (do-test suite test)))
18.121+
18.122+(defmethod do-test ((self symbol) &optional test)
18.123+ (do-test (symbol-name self) test))
18.124+
18.125 ;; HACK 2023-09-01: find better method of declaring failures from
18.126 ;; within the body of `deftest'.
18.127 (defmethod do-suite ((self test-suite) &key stream force)
19.1--- a/lisp/lib/vc/err.lisp Tue Apr 16 21:52:55 2024 -0400
19.2+++ b/lisp/lib/vc/err.lisp Wed Apr 17 22:53:44 2024 -0400
19.3@@ -1,6 +1,6 @@
19.4 (in-package :vc)
19.5
19.6-(deferror vc-error (std-error) ())
19.7+(define-condition vc-error (std-error) ())
19.8
19.9 (deferror git-error (vc-error) ())
19.10
20.1--- a/lisp/lib/xdb/tests.lisp Tue Apr 16 21:52:55 2024 -0400
20.2+++ b/lisp/lib/xdb/tests.lisp Wed Apr 17 22:53:44 2024 -0400
20.3@@ -106,9 +106,6 @@
20.4 (if (equal (mod i 100000) 0)
20.5 (sb-ext:gc :full t))))
20.6
20.7-
20.8-
20.9-
20.10 (defun test-store-doc-storable-object (collection times)
20.11 (dotimes (i times)
20.12 (store-doc collection
20.13@@ -147,7 +144,6 @@
20.14 (if (equal (mod i 100000) 0)
20.15 (sb-ext:gc :full t))))
20.16
20.17-
20.18 (defun test-store-doc-hash (collection times)
20.19 (dotimes (i times)
20.20 (let ((hash (make-hash-table :test 'equal)))
21.1--- a/lisp/lib/xdb/xdb.lisp Tue Apr 16 21:52:55 2024 -0400
21.2+++ b/lisp/lib/xdb/xdb.lisp Wed Apr 17 22:53:44 2024 -0400
21.3@@ -246,8 +246,7 @@
21.4 (defun sort-key (doc)
21.5 (get-val doc 'key))
21.6
21.7-;;TODO: How to update log if collection is sorted? Make a snapshot?
21.8-
21.9+;; TODO: How to update log if collection is sorted? Make a snapshot?
21.10 (defmethod sort-collection ((collection collection)
21.11 &key return-sort
21.12 (sort-value-func #'sort-key) (sort-test-func #'>))
22.1--- a/lisp/lisp.sk Tue Apr 16 21:52:55 2024 -0400
22.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3@@ -1,7 +0,0 @@
22.4-;;; lisp.sk --- lisp skelfile -*- mode: skel; -*-
22.5-:name "core/lisp"
22.6-:author "Richard Westhaver <ellis@rwest.io>"
22.7-:version "0.1.0"
22.8-:description "The Compiler Company Lisp Core"
22.9-:rules
22.10-(("clean" () #rm -rf */*.fasl#))
23.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
23.2+++ b/lisp/skelfile Wed Apr 17 22:53:44 2024 -0400
23.3@@ -0,0 +1,7 @@
23.4+;;; lisp.sk --- lisp skelfile -*- mode: skel; -*-
23.5+:name "core/lisp"
23.6+:author "Richard Westhaver <ellis@rwest.io>"
23.7+:version "0.1.0"
23.8+:description "The Compiler Company Lisp Core"
23.9+:rules (("clean" () #rm -rf */*.fasl#)
23.10+ ("x" () #./x.lisp#))
24.1--- a/lisp/std/fmt.lisp Tue Apr 16 21:52:55 2024 -0400
24.2+++ b/lisp/std/fmt.lisp Wed Apr 17 22:53:44 2024 -0400
24.3@@ -23,7 +23,6 @@
24.4 (format t ";; *print-readably* = ~a~%" *print-readably*)
24.5 (format t ";; *print-right-margin* = ~a~%" *print-right-margin*))
24.6
24.7-;;; Tables
24.8 (defun fmt-row (data)
24.9 (format nil "| ~{~A~^ | ~} |~%" data))
24.10
24.11@@ -40,9 +39,7 @@
24.12 (lambda (x) (format nil "~{~(~2,'0x~)~}" x))
24.13 (group r 2)))))
24.14
24.15-;;; ASCII
24.16-
24.17-;;;; Trees
24.18+;;; Trees
24.19
24.20 ;; from https://gist.github.com/WetHat/9682b8f70f0241c37cd5d732784d1577
24.21
25.1--- a/lisp/std/fu.lisp Tue Apr 16 21:52:55 2024 -0400
25.2+++ b/lisp/std/fu.lisp Wed Apr 17 22:53:44 2024 -0400
25.3@@ -615,7 +615,7 @@
25.4 table)
25.5 values))
25.6
25.7-(defun my-lisp-implementation ()
25.8+(defun current-lisp-implementation ()
25.9 "Return the current lisp implemenation as a cons: (TYPE VERSION)"
25.10 (list
25.11 (lisp-implementation-type)
26.1--- a/lisp/std/list.lisp Tue Apr 16 21:52:55 2024 -0400
26.2+++ b/lisp/std/list.lisp Wed Apr 17 22:53:44 2024 -0400
26.3@@ -98,3 +98,27 @@
26.4 (let ((elt (car tail)))
26.5 (circularp elt (cons object seen))))))))))
26.6 (circularp object nil)))
26.7+
26.8+(defun group (source n)
26.9+ (when (zerop n) (error "zero length"))
26.10+ (labels ((rec (source acc)
26.11+ (let ((rest (nthcdr n source)))
26.12+ (if (consp rest)
26.13+ (rec rest (cons
26.14+ (subseq source 0 n)
26.15+ acc))
26.16+ (nreverse
26.17+ (cons source acc))))))
26.18+ (if source (rec source nil) nil)))
26.19+
26.20+(eval-when (:compile-toplevel :execute :load-toplevel)
26.21+ (defun flatten (x)
26.22+ (labels ((rec (x acc)
26.23+ (cond ((null x) acc)
26.24+ #+sbcl
26.25+ ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc))
26.26+ ((atom x) (cons x acc))
26.27+ (t (rec
26.28+ (car x)
26.29+ (rec (cdr x) acc))))))
26.30+ (rec x nil))))
27.1--- a/lisp/std/os.lisp Tue Apr 16 21:52:55 2024 -0400
27.2+++ b/lisp/std/os.lisp Wed Apr 17 22:53:44 2024 -0400
27.3@@ -1,6 +1,6 @@
27.4 ;;; std/os.lisp --- OS interop definitions
27.5
27.6-;; mostly POSIX stuff. Windows is not supported.
27.7+;; UNIX only.
27.8
27.9 ;;; Code:
27.10 (in-package :std)
28.1--- a/lisp/std/pkg.lisp Tue Apr 16 21:52:55 2024 -0400
28.2+++ b/lisp/std/pkg.lisp Wed Apr 17 22:53:44 2024 -0400
28.3@@ -108,8 +108,9 @@
28.4 :make-threads :with-threads :finish-threads
28.5 :timed-join-thread :kill-thread :hang
28.6 :thread-count :dump-thread
28.7- :make-oracle :make-supervisor :oracle
28.8+ :make-oracle :make-supervisor :oracle :run-task
28.9 :push-job :push-task :push-worker :push-result
28.10+ :run-job :run-stage
28.11 :pop-job :pop-task :pop-worker :pop-result
28.12 :start-task-pool :pause-task-pool :shutdown-task-pool
28.13 :push-stage :designate-oracle :make-task-pool
28.14@@ -204,7 +205,7 @@
28.15 :hash-table-keys
28.16 :maphash-values
28.17 :hash-table-values
28.18- :my-lisp-implementation
28.19+ :current-lisp-implementation
28.20 :tmpfile
28.21 :ensure-function
28.22 :ensure-functionf
28.23@@ -278,4 +279,4 @@
28.24 :_))
28.25
28.26 (defpackage :std-user
28.27- (:use :cl :std))
28.28+ (:use :cl :cl-user :std))
29.1--- a/lisp/std/sym.lisp Tue Apr 16 21:52:55 2024 -0400
29.2+++ b/lisp/std/sym.lisp Wed Apr 17 22:53:44 2024 -0400
29.3@@ -62,6 +62,33 @@
29.4 name
29.5 (string name))))
29.6
29.7+(defun mkstr (&rest args)
29.8+ (with-output-to-string (s)
29.9+ (dolist (a args) (princ a s))))
29.10+
29.11+(defun symb (&rest args)
29.12+ (values (intern (apply #'mkstr args))))
29.13+
29.14+(defun g!-symbol-p (s)
29.15+ (and (symbolp s)
29.16+ (> (length (symbol-name s)) 2)
29.17+ (string= (symbol-name s)
29.18+ "G!"
29.19+ :start1 0
29.20+ :end1 2)))
29.21+
29.22+(defun o!-symbol-p (s)
29.23+ (and (symbolp s)
29.24+ (> (length (symbol-name s)) 2)
29.25+ (string= (symbol-name s)
29.26+ "O!"
29.27+ :start1 0
29.28+ :end1 2)))
29.29+
29.30+(defun o!-symbol-to-g!-symbol (s)
29.31+ (symb "G!"
29.32+ (subseq (symbol-name s) 2)))
29.33+
29.34 (sb-ext:with-unlocked-packages (:sb-int)
29.35 (handler-bind
29.36 ((sb-kernel:redefinition-warning #'muffle-warning))
30.1--- a/lisp/std/thread.lisp Tue Apr 16 21:52:55 2024 -0400
30.2+++ b/lisp/std/thread.lisp Wed Apr 17 22:53:44 2024 -0400
30.3@@ -220,6 +220,9 @@
30.4 (defmethod push-result ((task task) (pool task-pool))
30.5 (sb-concurrency:enqueue task (task-pool-results pool)))
30.6
30.7+(defmethod run-task ((self thread) (task task))
30.8+ )
30.9+
30.10 (defstruct (job (:constructor %make-job (tasks)))
30.11 "A collection of tasks to be performed by worker threads."
30.12 (tasks (make-array 0 :element-type 'task :fill-pointer 0 :adjustable t)
30.13@@ -247,6 +250,9 @@
30.14 (defmethod push-job ((job job) (pool task-pool))
30.15 (sb-concurrency:enqueue job (task-pool-jobs pool)))
30.16
30.17+(defmethod run-job ((self thread) (job job))
30.18+ )
30.19+
30.20 (defclass stage ()
30.21 ((jobs :initform (make-array 0 :element-type 'task :fill-pointer 0 :adjustable t)
30.22 :initarg :jobs
30.23@@ -259,3 +265,5 @@
30.24
30.25 (defmethod push-stage ((stage stage) (pool task-pool))
30.26 (vector-push stage (task-pool-stages pool)))
30.27+
30.28+(defmethod run-stage ((self thread) (stage stage)))
31.1--- a/lisp/std/util.lisp Tue Apr 16 21:52:55 2024 -0400
31.2+++ b/lisp/std/util.lisp Wed Apr 17 22:53:44 2024 -0400
31.3@@ -11,59 +11,6 @@
31.4 (return-from ,block-name nil)
31.5 (progn ,@body))))))
31.6
31.7-;;; From LOL
31.8-
31.9-(defun group (source n)
31.10- (when (zerop n) (error "zero length"))
31.11- (labels ((rec (source acc)
31.12- (let ((rest (nthcdr n source)))
31.13- (if (consp rest)
31.14- (rec rest (cons
31.15- (subseq source 0 n)
31.16- acc))
31.17- (nreverse
31.18- (cons source acc))))))
31.19- (if source (rec source nil) nil)))
31.20-
31.21-(eval-when (:compile-toplevel :execute :load-toplevel)
31.22- (defun mkstr (&rest args)
31.23- (with-output-to-string (s)
31.24- (dolist (a args) (princ a s))))
31.25-
31.26- (defun symb (&rest args)
31.27- (values (intern (apply #'mkstr args))))
31.28-
31.29- (defun flatten (x)
31.30- (labels ((rec (x acc)
31.31- (cond ((null x) acc)
31.32- #+sbcl
31.33- ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc))
31.34- ((atom x) (cons x acc))
31.35- (t (rec
31.36- (car x)
31.37- (rec (cdr x) acc))))))
31.38- (rec x nil)))
31.39-
31.40- (defun g!-symbol-p (s)
31.41- (and (symbolp s)
31.42- (> (length (symbol-name s)) 2)
31.43- (string= (symbol-name s)
31.44- "G!"
31.45- :start1 0
31.46- :end1 2)))
31.47-
31.48- (defun o!-symbol-p (s)
31.49- (and (symbolp s)
31.50- (> (length (symbol-name s)) 2)
31.51- (string= (symbol-name s)
31.52- "O!"
31.53- :start1 0
31.54- :end1 2)))
31.55-
31.56- (defun o!-symbol-to-g!-symbol (s)
31.57- (symb "G!"
31.58- (subseq (symbol-name s) 2))))
31.59-
31.60 (defmacro defmacro/g! (name args &rest body)
31.61 (let ((syms (remove-duplicates
31.62 (remove-if-not #'g!-symbol-p
31.63@@ -125,45 +72,46 @@
31.64 `(cdr ,g!args)))))
31.65 ds))))
31.66
31.67-(declaim (inline make-tlist tlist-left
31.68- tlist-right tlist-empty-p))
31.69+;; LoL tlist
31.70+;; (declaim (inline make-tlist tlist-left
31.71+;; tlist-right tlist-empty-p))
31.72
31.73-(defun make-tlist () (cons nil nil))
31.74-(defun tlist-left (tl) (caar tl))
31.75-(defun tlist-right (tl) (cadr tl))
31.76-(defun tlist-empty-p (tl) (null (car tl)))
31.77+;; (defun make-tlist () (cons nil nil))
31.78+;; (defun tlist-left (tl) (caar tl))
31.79+;; (defun tlist-right (tl) (cadr tl))
31.80+;; (defun tlist-empty-p (tl) (null (car tl)))
31.81
31.82-(declaim (inline tlist-add-left
31.83- tlist-add-right))
31.84+;; (declaim (inline tlist-add-left
31.85+;; tlist-add-right))
31.86
31.87-(defun tlist-add-left (tl it)
31.88- (let ((x (cons it (car tl))))
31.89- (if (tlist-empty-p tl)
31.90- (setf (cdr tl) x))
31.91- (setf (car tl) x)))
31.92+;; (defun tlist-add-left (tl it)
31.93+;; (let ((x (cons it (car tl))))
31.94+;; (if (tlist-empty-p tl)
31.95+;; (setf (cdr tl) x))
31.96+;; (setf (car tl) x)))
31.97
31.98-(defun tlist-add-right (tl it)
31.99- (let ((x (cons it nil)))
31.100- (if (tlist-empty-p tl)
31.101- (setf (car tl) x)
31.102- (setf (cddr tl) x))
31.103- (setf (cdr tl) x)))
31.104+;; (defun tlist-add-right (tl it)
31.105+;; (let ((x (cons it nil)))
31.106+;; (if (tlist-empty-p tl)
31.107+;; (setf (car tl) x)
31.108+;; (setf (cddr tl) x))
31.109+;; (setf (cdr tl) x)))
31.110
31.111-(declaim (inline tlist-rem-left))
31.112+;; (declaim (inline tlist-rem-left))
31.113
31.114-(defun tlist-rem-left (tl)
31.115- (if (tlist-empty-p tl)
31.116- (error "Remove from empty tlist")
31.117- (let ((x (car tl)))
31.118- (setf (car tl) (cdar tl))
31.119- (if (tlist-empty-p tl)
31.120- (setf (cdr tl) nil)) ;; For gc
31.121- (car x))))
31.122+;; (defun tlist-rem-left (tl)
31.123+;; (if (tlist-empty-p tl)
31.124+;; (error "Remove from empty tlist")
31.125+;; (let ((x (car tl)))
31.126+;; (setf (car tl) (cdar tl))
31.127+;; (if (tlist-empty-p tl)
31.128+;; (setf (cdr tl) nil)) ;; For gc
31.129+;; (car x))))
31.130
31.131-(declaim (inline tlist-update))
31.132+;; (declaim (inline tlist-update))
31.133
31.134-(defun tlist-update (tl)
31.135- (setf (cdr tl) (last (car tl))))
31.136+;; (defun tlist-update (tl)
31.137+;; (setf (cdr tl) (last (car tl))))
31.138
31.139 (defun build-batcher-sn (n)
31.140 (let* (network
32.1--- a/rust/rust.sk Tue Apr 16 21:52:55 2024 -0400
32.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
32.3@@ -1,7 +0,0 @@
32.4-;;; rust.sk --- core/rust skelfile -*- mode: skel; -*-
32.5-:name "core/rust"
32.6-:version "0.1.0"
32.7-:description "Rust Core"
32.8-:tags ("rust")
32.9-:rules
32.10-(("clean" () #$cargo clean$#))
33.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
33.2+++ b/rust/skelfile Wed Apr 17 22:53:44 2024 -0400
33.3@@ -0,0 +1,7 @@
33.4+;;; rust.sk --- core/rust skelfile -*- mode: skel; -*-
33.5+:name "core/rust"
33.6+:version "0.1.0"
33.7+:description "Rust Core"
33.8+:tags ("rust")
33.9+:rules
33.10+(("clean" () #$cargo clean$#))
34.1--- a/skelfile Tue Apr 16 21:52:55 2024 -0400
34.2+++ b/skelfile Wed Apr 17 22:53:44 2024 -0400
34.3@@ -7,6 +7,10 @@
34.4 :vc :hg
34.5 :tags ("core")
34.6 :docs ((:org "readme") (:org "install") (:org "tests") (:org "todo"))
34.7-:imports ("lisp/lisp.sk" "rust/rust.sk")
34.8+:imports ("lisp/skelfile" "rust/skelfile" "emacs/skelfile" "c/skelfile")
34.9 :rules
34.10-((box #$podman build .$#))
34.11+((box #$podman build .$#)
34.12+ (clean #$rm -rf .stash/$#
34.13+ #$cd rust && cargo clean$#
34.14+ #$cd emacs && rm -rf */*.elc$#
34.15+ #$cd lisp && rm -rf */*.fasl))
35.1--- a/x.lisp Tue Apr 16 21:52:55 2024 -0400
35.2+++ b/x.lisp Wed Apr 17 22:53:44 2024 -0400
35.3@@ -14,30 +14,36 @@
35.4 (require 'sb-introspect)
35.5 (require 'sb-grovel)
35.6 (require 'sb-cltl2)
35.7-(defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
35.8-(defvar *lisp-path* (merge-pathnames "lisp/" *core-path*))
35.9-(defvar *lib-path* (merge-pathnames "lib/" *lisp-path*))
35.10-(defvar *std-path* (merge-pathnames "std/" *lisp-path*))
35.11-(defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
35.12-(defvar *core-stash* (merge-pathnames ".stash/" *core-path*))
35.13-
35.14-(push *core-path* asdf:*central-registry*)
35.15
35.16 #-quicklisp
35.17 (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname))))
35.18 (when (probe-file quicklisp-init)
35.19 (load quicklisp-init)))
35.20
35.21-
35.22 (unless (asdf:find-system :cl-ppcre nil)
35.23 (ql:quickload :cl-ppcre)
35.24 ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd"))
35.25 )
35.26
35.27-(asdf:load-asd (probe-file (merge-pathnames "std.asd" *std-path*)))
35.28+(asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/std.asd")))
35.29 (asdf:load-system :std)
35.30-(use-package :std)
35.31-(in-readtable :std)
35.32+(defpackage :x
35.33+ (:use :cl :std :std/named-readtables)
35.34+ (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*app-path* :*bin-path*))
35.35+
35.36+(in-package :x)
35.37+
35.38+(defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
35.39+
35.40+(push *core-path* asdf:*central-registry*)
35.41+
35.42+(defvar *lisp-path* (merge-pathnames "lisp/" *core-path*))
35.43+(defvar *app-path* (merge-pathnames "app/" *lisp-path*))
35.44+(defvar *bin-path* (merge-pathnames "bin/" *app-path*))
35.45+(defvar *lib-path* (merge-pathnames "lib/" *lisp-path*))
35.46+(defvar *std-path* (merge-pathnames "std/" *lisp-path*))
35.47+(defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
35.48+(defvar *stash-path* (merge-pathnames ".stash/" *core-path*))
35.49
35.50 (unless (asdf:find-system :log nil)
35.51 (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*))))
35.52@@ -55,53 +61,51 @@
35.53 (asdf:load-system :cli)
35.54 (use-package :cli)
35.55
35.56-(defun compile-std (&optional save)
35.57- (cl:in-package :user)
35.58+(defun done () (print :OK))
35.59+
35.60+(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
35.61+ (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression t))
35.62+
35.63+(defun compile-std (&optional force save)
35.64 (let ((v (getflag "VERSION")))
35.65- (asdf:compile-system :std :force t :version v)
35.66- (asdf:load-system :std :force t :version v)
35.67- (when save (sb-ext:save-lisp-and-die "std" :compression nil))))
35.68+ (asdf:compile-system :std :force force :version v)
35.69+ (asdf:load-system :std :force force :version v)
35.70+ (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression nil))))
35.71
35.72-(defun compile-prelude (&optional save)
35.73- (compile-std)
35.74+(defun compile-prelude (&optional force save)
35.75+ ;; (compile-std)
35.76 (push (pathname *lisp-path*) ql:*local-project-directories*)
35.77- (mapc #'ql:quickload
35.78- '(:rocksdb :xkb :btrfs
35.79- :nlp :rdb :organ :packy :skel
35.80- :obj :net :parse :pod :dat
35.81- :rt :syn :xdb :doc :vc))
35.82- (use-package :std)
35.83- (use-package :log)
35.84- (use-package :dat)
35.85- (use-package :net)
35.86- (use-package :rdb)
35.87- (asdf:make :prelude)
35.88+ (ql:quickload :prelude)
35.89+ (asdf:compile-system :prelude :force force)
35.90 (rocksdb:load-rocksdb save)
35.91- (when save (sb-ext:save-lisp-and-die "prelude" :compression 19)))
35.92+ (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression 19)))
35.93+
35.94+(defun save-foreign (name exports &rest args)
35.95+ (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
35.96
35.97+(sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude))
35.98+(sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
35.99+
35.100+(defvar *x-thunk* nil)
35.101+(defvar *x-args* nil)
35.102 #-(or sbcl cl) (error "unsupported Lisp compiler")
35.103 (setq *print-level* 32
35.104- *print-length* 256)
35.105+ *print-length* 64)
35.106 ;; collect args from shell
35.107 (defvar *args* (cdr sb-ext:*posix-argv*))
35.108 (defvar *flags*
35.109 '((version "0.1.0")
35.110 (help "x --- core build tool
35.111-
35.112-x.lisp [OPT] [CMD] [ARGS...]
35.113-OPTS:
35.114---version/v
35.115---help/h
35.116---level/l
35.117---jobs/j
35.118+x.lisp [CMD] [OPTS...]
35.119 CMDS:
35.120 build
35.121 run
35.122 test
35.123-")
35.124- (quicklisp t)
35.125- (prelude t)
35.126- (jobs 4)))
35.127+save
35.128+OPTS:
35.129+--version/v
35.130+--help/h
35.131+")))
35.132
35.133 (defun getflag (k)
35.134 (cadar
35.135@@ -121,9 +125,7 @@
35.136 (if (or (characterp k) (= (length k) 1))
35.137 (case (char-downcase (character k))
35.138 (#\v "VERSION")
35.139- (#\h "HELP")
35.140- (#\l "LEVEL")
35.141- (#\j "JOBS"))
35.142+ (#\h "HELP"))
35.143 k)))
35.144 (if (char-equal (aref arg 0) #\-)
35.145 (if (= (length arg) 2) ;; short
35.146@@ -134,51 +136,62 @@
35.147
35.148 ;; (defun parse-arg (arg))
35.149
35.150-(defun done () (print :OK))
35.151+(defun x-build (&optional args)
35.152+ (ensure-directories-exist *stash-path*)
35.153+ (compile-prelude nil nil)
35.154+ (let ((name (car args)))
35.155+ (info! "saving executable to:" (merge-pathnames name *stash-path*))
35.156+ (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name)))))
35.157+ (asdf:load-asd (merge-pathnames "bin.asd" *bin-path*))
35.158+ (asdf:make sys))))
35.159+
35.160+(defun x-run (&optional args))
35.161+
35.162+(defun x-test (&optional args)
35.163+ (if args
35.164+ (let ((name (car args)))
35.165+ (compile-prelude nil nil)
35.166+ (ignore-some-conditions (warning) (asdf:test-system name)))))
35.167
35.168 (defun x-parse-args ()
35.169- (tagbody
35.170- 0
35.171- (cond
35.172- ((null *args*) nil)
35.173- ((= 1 (length *args*))
35.174- (let ((flag? (parse-flag (car *args*))))
35.175- (cond
35.176- (flag?
35.177- (cond
35.178- ((equalp flag? "help") (princ (getflag flag?)) (sb-ext:exit :code 0))
35.179- ((equalp flag? "version") (princ (getflag flag?)) (sb-ext:exit :code 0))
35.180- ((equalp flag? "level") (setflag flag? t))
35.181- ((equalp flag? "jobs") (setflag flag? (cadr *args*)))
35.182- (t (error "invalid flag") (sb-ext:exit :code 0))))
35.183- (t (error "invalid arg") (sb-ext:exit :code 0))))))
35.184- ok (done)))
35.185-
35.186-(defun save-foreign (name exports &rest args)
35.187- (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
35.188-
35.189-(sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude))
35.190-(sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
35.191+ (if (null *args*)
35.192+ (progn
35.193+ (println "Welcome to CORE/X")
35.194+ (in-package :std-user)
35.195+ (sb-impl::toplevel-repl nil)
35.196+ (sb-ext:exit :code 0))
35.197+ (let ((cmd (pop *args*)))
35.198+ (cond
35.199+ ((equal cmd "build") (setq *x-thunk* #'x-build))
35.200+ ((equal cmd "run") (setq *x-thunk* #'x-run))
35.201+ ((equal cmd "test") (setq *x-thunk* #'x-test))
35.202+ ((equal cmd "save") (setq *x-thunk* #'x-save))
35.203+ (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0))))))
35.204
35.205 (defun x-init ()
35.206- (sb-impl::toplevel-init))
35.207-
35.208-(defun x-repl (&optional noprint)
35.209- (sb-impl::toplevel-repl noprint))
35.210-
35.211-(defun x-respawn (&optional noprint)
35.212- (x-init)
35.213- (done))
35.214+ (in-package :x)
35.215+ (let ((*args* (cdr sb-ext:*posix-argv*)))
35.216+ (x-parse-args)
35.217+ (compile-prelude nil nil)
35.218+ (log:info! "running command" *x-thunk* *args*)
35.219+ (funcall *x-thunk* *args*)))
35.220
35.221-;; (save-lisp-and-live "x" #'respawn #'respawn :executable t :save-runtime-options t)
35.222-(defun x-save ()
35.223- (save-lisp-tree-shake-and-die "x"
35.224- :toplevel #'x-respawn
35.225- ;; :callable-exports '("compile_std" "compile_prelude")
35.226- :purify t
35.227- :executable t
35.228- :save-runtime-options t))
35.229+(defun x-save (&optional args)
35.230+ (if args
35.231+ (let ((name (car args)))
35.232+ (info! "saving core to:" (merge-pathnames name *stash-path*))
35.233+ (string-case (name)
35.234+ ("prelude" (compile-prelude t))
35.235+ ("std" (compile-std t))))
35.236+ ;; self save
35.237+ (progn
35.238+ (info! "saving self to ./x")
35.239+ (sb-ext:save-lisp-and-die "x"
35.240+ :toplevel #'x-init
35.241+ ;; :callable-exports '("compile_std" "compile_prelude")
35.242+ :purify t
35.243+ :executable t
35.244+ :save-runtime-options t))))
35.245
35.246-(x-parse-args)
35.247 (x-save)
35.248 ;; (x-repl)
