1.1--- a/.hgsub Sun Oct 15 22:00:24 2023 -0400
1.2+++ b/.hgsub Mon Oct 16 19:33:42 2023 -0400
1.3@@ -1,3 +1,2 @@
1.4-lisp/macs = ssh://git@lab.rwest.io/ellis/macs
1.5 lisp/lib/skel = ssh://git@lab.rwest.io/ellis/skel
1.6 lisp/lib/organ = ssh://git@lab.rwest.io/ellis/organ
1.7\ No newline at end of file
2.1--- a/.hgsubstate Sun Oct 15 22:00:24 2023 -0400
2.2+++ b/.hgsubstate Mon Oct 16 19:33:42 2023 -0400
2.3@@ -1,3 +1,2 @@
2.4 fed991c01753ff72fe66954786e85ba813138521 lisp/lib/organ
2.5 2917dbd4a30bd52fe8ca84f8395105f2bdd6da6c lisp/lib/skel
2.6-f3f22d17b55b23a50be8b5b97aa1c80d21547bee lisp/macs
3.1--- a/lisp/ffi/rocksdb/rocksdb.lisp Sun Oct 15 22:00:24 2023 -0400
3.2+++ b/lisp/ffi/rocksdb/rocksdb.lisp Mon Oct 16 19:33:42 2023 -0400
3.3@@ -136,7 +136,7 @@
3.4 (define-alien-type rocksdb-errptr (* (* t)))
3.5
3.6 ;;; Cache
3.7-(define-alien-routine rocksdb-cache-create-lru (* rocksdb) (capacity unsigned-int))
3.8+(define-alien-routine rocksdb-cache-create-lru (* rocksdb) (capacity u32))
3.9
3.10 ;;; Options
3.11
3.12@@ -152,43 +152,43 @@
3.13 (val c-string))
3.14
3.15 ;;;; db
3.16-(define-alien-routine rocksdb-options-create rocksdb-options)
3.17+(define-alien-routine rocksdb-options-create (* rocksdb-options))
3.18 (define-alien-routine rocksdb-options-destroy void
3.19 (options rocksdb-options))
3.20 (define-alien-routine rocksdb-options-increase-parallelism void
3.21- (opt rocksdb-options) (total-threads int))
3.22+ (opt (* rocksdb-options)) (total-threads int))
3.23 (define-alien-routine rocksdb-options-optimize-level-style-compaction void
3.24- (opt rocksdb-options)
3.25- (memtable_memory_budget (unsigned 4)))
3.26+ (opt (* rocksdb-options))
3.27+ (memtable-memory-budget u64))
3.28 (define-alien-routine rocksdb-options-set-create-if-missing void
3.29- (opt rocksdb-options)
3.30+ (opt (* rocksdb-options))
3.31 (val boolean))
3.32 (define-alien-routine rocksdb-options-set-block-based-table-factory void
3.33- (opt rocksdb-options)
3.34- (table-options rocksdb-block-based-table-options))
3.35+ (opt (* rocksdb-options))
3.36+ (table-options (* rocksdb-block-based-table-options)))
3.37 ;;;; write
3.38-(define-alien-routine rocksdb-writeoptions-create rocksdb-writeoptions)
3.39+(define-alien-routine rocksdb-writeoptions-create (* rocksdb-writeoptions))
3.40 (define-alien-routine rocksdb-writeoptions-destroy void
3.41- (opt rocksdb-writeoptions))
3.42+ (opt (* rocksdb-writeoptions)))
3.43 ;;;; read
3.44-(define-alien-routine rocksdb-readoptions-create rocksdb-readoptions)
3.45+(define-alien-routine rocksdb-readoptions-create (* rocksdb-readoptions))
3.46 (define-alien-routine rocksdb-readoptions-destroy void
3.47- (opt rocksdb-readoptions))
3.48+ (opt (* rocksdb-readoptions)))
3.49
3.50 ;;; DB
3.51-(define-alien-routine rocksdb-open rocksdb
3.52- (opt rocksdb-options)
3.53+(define-alien-routine rocksdb-open (* rocksdb)
3.54+ (opt (* rocksdb-options))
3.55 (name c-string)
3.56 (errptr rocksdb-errptr))
3.57 (define-alien-routine rocksdb-close void
3.58- (db rocksdb))
3.59+ (db (* rocksdb)))
3.60 (define-alien-routine rocksdb-cancel-all-background-work void
3.61- (db rocksdb)
3.62+ (db (* rocksdb))
3.63 (wait boolean))
3.64
3.65 (define-alien-routine rocksdb-put void
3.66- (db rocksdb)
3.67- (options rocksdb-writeoptions)
3.68+ (db (* rocksdb))
3.69+ (options (* rocksdb-writeoptions))
3.70 (key (* char))
3.71 (keylen size-t)
3.72 (val (* char))
3.73@@ -196,40 +196,40 @@
3.74 (errptr rocksdb-errptr))
3.75
3.76 (define-alien-routine rocksdb-get (* char)
3.77- (db rocksdb)
3.78- (options rocksdb-readoptions)
3.79+ (db (* rocksdb))
3.80+ (options (* rocksdb-readoptions))
3.81 (key (* char))
3.82 (keylen size-t)
3.83 (vallen (* size-t))
3.84 (errptr rocksdb-errptr))
3.85
3.86 (define-alien-routine rocksdb-delete void
3.87- (db rocksdb)
3.88- (options rocksdb-writeoptions)
3.89+ (db (* rocksdb))
3.90+ (options (* rocksdb-writeoptions))
3.91 (key (* char))
3.92 (keylen size-t)
3.93 (errptr rocksdb-errptr))
3.94
3.95 ;;; Iterators
3.96-(define-alien-routine rocksdb-create-iterator rocksdb-iterator
3.97- (db rocksdb)
3.98- (opt rocksdb-readoptions))
3.99+(define-alien-routine rocksdb-create-iterator (* rocksdb-iterator)
3.100+ (db (* rocksdb))
3.101+ (opt (* rocksdb-readoptions)))
3.102 (define-alien-routine rocksdb-iter-destroy void
3.103- (iter rocksdb-iterator))
3.104+ (iter (* rocksdb-iterator)))
3.105 (define-alien-routine rocksdb-iter-seek-to-first void
3.106- (iter rocksdb-iterator))
3.107+ (iter (* rocksdb-iterator)))
3.108 (define-alien-routine rocksdb-iter-valid boolean
3.109- (iter rocksdb-iterator))
3.110+ (iter (* rocksdb-iterator)))
3.111 (define-alien-routine rocksdb-iter-next void
3.112- (iter rocksdb-iterator))
3.113+ (iter (* rocksdb-iterator)))
3.114 (define-alien-routine rocksdb-iter-prev void
3.115- (iter rocksdb-iterator))
3.116+ (iter (* rocksdb-iterator)))
3.117 (define-alien-routine rocksdb-iter-key (* char)
3.118- (iter rocksdb-iterator)
3.119+ (iter (* rocksdb-iterator))
3.120 (klen-ptr (* size-t)))
3.121 (define-alien-routine rocksdb-iter-value (* char)
3.122- (iter rocksdb-iterator) (vlen-ptr (* size-t)))
3.123+ (iter (* rocksdb-iterator)) (vlen-ptr (* size-t)))
3.124 (define-alien-routine rocksdb-destroy-db void
3.125- (options rocksdb-options)
3.126+ (options (* rocksdb-options))
3.127 (name c-string)
3.128 (errptr rocksdb-errptr))
4.1--- a/lisp/lib/cli/tests.lisp Sun Oct 15 22:00:24 2023 -0400
4.2+++ b/lisp/lib/cli/tests.lisp Mon Oct 16 19:33:42 2023 -0400
4.3@@ -0,0 +1,46 @@
4.4+;; we should be able to call this from the body of the test, but we
4.5+;; get an undefined-function error for 'MACS.RT::MAKE-PROMPT!'
4.6+(defpkg :cli/tests
4.7+ (:use :cl :rt :cli))
4.8+
4.9+(defsuite :cli)
4.10+(in-suite :cli)
4.11+(unless *compile-tests*
4.12+ (deftest cli-prompt ()
4.13+ "Test MACS.CLI prompts"
4.14+ (make-prompt! tpfoo "testing: ")
4.15+ (defvar tcoll nil)
4.16+ (defvar thist nil)
4.17+ (let ((*standard-input* (make-string-input-stream
4.18+ (format nil "~A~%~A~%" "foobar" "foobar"))))
4.19+ ;; prompts
4.20+ (is (string= (tpfoo-prompt) "foobar"))
4.21+ (is (string= "foobar"
4.22+ (cli:completing-read "nothing: " tcoll :history thist :default "foobar"))))))
4.23+
4.24+(defparameter *opts* (cli:make-opts (:name foo :global t :description "bar")
4.25+ (:name bar :description "foo")))
4.26+
4.27+(defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description"))
4.28+(defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds #(*cmd1*) :opts *opts* :description "cmd1 description"))
4.29+(defparameter *cmds* (cli:make-cmds (:name "baz" :description "baz" :opts *opts*)))
4.30+
4.31+(defparameter *cli* (make-cli t :opts *opts* :cmds *cmds* :description "test cli"))
4.32+
4.33+(deftest cli ()
4.34+ "test MACS.CLI OOS."
4.35+ (let ((cli *cli*))
4.36+ (is (eq (make-shorty "test") #\t))
4.37+ (is (equalp (proc-args cli '("-f" "baz" "--bar" "fax")) ;; not eql
4.38+ (make-cli-ast
4.39+ (list (make-cli-node 'opt (find-short-opt cli #\f))
4.40+ (make-cli-node 'cmd (find-cmd cli "baz"))
4.41+ (make-cli-node 'opt (find-opt cli "bar"))
4.42+ (make-cli-node 'arg "fax")))))
4.43+ (is (parse-args cli '("--bar" "baz" "-f" "yaks")))
4.44+ (is (stringp
4.45+ (with-output-to-string (s)
4.46+ (print-version cli s)
4.47+ (print-usage cli s)
4.48+ (print-help cli s))))
4.49+ (is (string= "foobar" (parse-str-opt "foobar")))))
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/lib/rt/tests.lisp Mon Oct 16 19:33:42 2023 -0400
5.3@@ -0,0 +1,17 @@
5.4+;;; rt/tests.lisp
5.5+(defpkg :rt/tests
5.6+ (:use :cl :rt))
5.7+(defsuite :rt)
5.8+(in-suite :rt)
5.9+(deftest rt (:bench 100 :profile t :persist nil)
5.10+ (is (typep (make-fixture-prototype :empty nil) 'fixture-prototype))
5.11+ (with-fixture (fx (make-fixture ((a 1) (b 2))
5.12+ (:+ () (+ (incf a) (incf b)))
5.13+ (:- () (- (decf a) (decf b)))
5.14+ (t () 0)))
5.15+ (is (= 5 (funcall fx :+)))
5.16+ (is (= 7 (funcall fx :+)))
5.17+ (is (= 5 (funcall fx :-)))
5.18+ (is (= 0 (funcall fx))))
5.19+ (signals (error t) (test-form (make-instance 'test-result))))
5.20+
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/lisp/std.asd Mon Oct 16 19:33:42 2023 -0400
6.3@@ -0,0 +1,7 @@
6.4+;;; std.asd --- standard library
6.5+(defsystem :std
6.6+ :pathname "std"
6.7+ :class :package-inferred-system
6.8+ :depends-on (:std/all)
6.9+ :in-order-to ((test-op (test-op "std/tests")))
6.10+ :perform (test-op (o c) (symbol-call :rt :do-tests :std)))
7.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2+++ b/lisp/std/alien.lisp Mon Oct 16 19:33:42 2023 -0400
7.3@@ -0,0 +1,106 @@
7.4+;;; std/alien.lisp --- foreign alien friends
7.5+
7.6+;;; Commentary:
7.7+
7.8+;; FFI in Lisp is somewhat different than FFI in other host langs. As
7.9+;; such, we usually refer to our Lispy FFI interfaces inline with the
7.10+;; CMUCL terminology: alien interfaces.
7.11+
7.12+;; ref: https://www.sbcl.org/manual/#Foreign-Function-Interface for details
7.13+
7.14+;; sb-alien is a high-level interface which automatically converts C
7.15+;; memory pointers to lisp objects and back, but this can be slow for
7.16+;; large or complex objects.
7.17+
7.18+;; The lower-level interface is based on System Area Pointers (or
7.19+;; SAPs), which provide untyped access to foreign memory.
7.20+
7.21+;; Objects which can't be automatically converted into Lisp values are
7.22+;; represented by objects of type ALIEN-VALUE.
7.23+
7.24+;;; Code:
7.25+(pkg:defpkg :std/alien
7.26+ (:nicknames :alien)
7.27+ (:use :cl :sb-vm :sb-ext :sb-c :str :sym :fu)
7.28+ (:use-reexport :sb-alien)
7.29+ (:export
7.30+ :copy-c-string
7.31+ :clone
7.32+ :foreign-int-to-integer :foreign-int-to-bool :bool-to-foreign-int
7.33+ :defbytes
7.34+ :u1 :u2 :u3 :u4 :u8 :u16 :u24 :u32 :u64 :u128
7.35+ :i2 :i3 :i4 :i8 :i16 :i24 :i32 :i64 :i128
7.36+ :f16 :f24 :f32 :f64 :f128))
7.37+
7.38+(in-package :alien)
7.39+
7.40+;; (reexport-from :sb-vm
7.41+;; :include
7.42+;; '(:with-pinned-objects :with-pinned-object-iterator :with-code-pages-pinned
7.43+;; :sanctify-for-execution))
7.44+
7.45+(defun copy-c-string (src dest &aux (index 0))
7.46+ (loop (let ((b (sb-sys:sap-ref-8 src index)))
7.47+ (when (= b 0)
7.48+ (setf (fill-pointer dest) index)
7.49+ (return))
7.50+ (setf (char dest index) (code-char b))
7.51+ (incf index))))
7.52+
7.53+(defun clone-strings (list)
7.54+ (with-alien ((x (* (* char))
7.55+ (make-alien (* char) (length list))))
7.56+ (unwind-protect
7.57+ (labels ((populate (list index function)
7.58+ (if list
7.59+ (let ((array (sb-ext:string-to-octets (car list) :null-terminate t)))
7.60+ (sb-sys:with-pinned-objects (array)
7.61+ (setf (deref x index) (sap-alien (sb-sys:vector-sap array) (* char)))
7.62+ (populate (cdr list) (1+ index) function)))
7.63+ (funcall function))))
7.64+ (populate list 0
7.65+ (lambda ()
7.66+ (loop for i below (length list)
7.67+ do (print (cast (deref x i) c-string))))))
7.68+ (free-alien x))))
7.69+
7.70+(defun foreign-int-to-integer (buffer size)
7.71+ "Check SIZE of int BUFFER. return BUFFER."
7.72+ (assert (= size (sb-alien:alien-size sb-alien:int :bytes)))
7.73+ buffer)
7.74+
7.75+(defun foreign-int-to-bool (x size)
7.76+ (if (zerop (foreign-int-to-integer x size))
7.77+ nil
7.78+ t))
7.79+
7.80+(defun bool-to-foreign-int (val)
7.81+ (if val 1 0))
7.82+
7.83+;;; Bytes
7.84+(defmacro defbytes (&body bitsets)
7.85+ "For each cons-cell in BITSETS, define a new CAR-byte type for each
7.86+member of CDR."
7.87+ `(loop for set in ',bitsets
7.88+ collect
7.89+ (let* ((ty (car set))
7.90+ (pfx
7.91+ (cond
7.92+ ((eq 'signed-byte ty) "I")
7.93+ ((eq 'unsigned-byte ty) "U")
7.94+ ((eq 'float ty) "F")
7.95+ (t (subseq (symbol-name ty) 0 1))))
7.96+ (nums (cdr set))
7.97+ r) ;result
7.98+ (setf r
7.99+ (mapc
7.100+ (lambda (x)
7.101+ `(deftype ,(symbolicate pfx (format 'nil "~a" x)) ()
7.102+ (cons ,ty ,x)))
7.103+ nums))
7.104+ (cons ty r))))
7.105+
7.106+(defbytes
7.107+ (unsigned-byte 1 2 3 4 8 16 24 32 64 128)
7.108+ (signed-byte 2 3 4 8 16 24 32 64 128)
7.109+ (float 16 24 32 64 128))
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/lisp/std/all.lisp Mon Oct 16 19:33:42 2023 -0400
8.3@@ -0,0 +1,14 @@
8.4+(defpkg :std/all
8.5+ (:nicknames :std)
8.6+ (:use-reexport
8.7+ :pkg
8.8+ :named-readtables
8.9+ :alien
8.10+ :ana
8.11+ :pan
8.12+ :log
8.13+ :str
8.14+ :sym
8.15+ :list
8.16+ :fmt
8.17+ :fs))
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/std/ana.lisp Mon Oct 16 19:33:42 2023 -0400
9.3@@ -0,0 +1,82 @@
9.4+;;; ana.lisp --- anaphoric macros
9.5+
9.6+;;; Code:
9.7+(defpackage :std/ana
9.8+ (:use :cl :readtables :fu)
9.9+ (:nicknames :ana)
9.10+ (:export
9.11+ #:alambda
9.12+ #:nlet-tail
9.13+ #:alet%
9.14+ #:alet
9.15+ #:acond2
9.16+ #:it
9.17+ #:aif
9.18+ #:this
9.19+ #:self))
9.20+
9.21+(in-package :macs.ana)
9.22+
9.23+(in-readtable :std)
9.24+
9.25+;; Graham's alambda
9.26+(defmacro alambda (parms &body body)
9.27+ `(labels ((self ,parms ,@body))
9.28+ #'self))
9.29+
9.30+;; Graham's aif
9.31+(defmacro aif (test then &optional else)
9.32+ `(let ((it ,test))
9.33+ (if it ,then ,else)))
9.34+
9.35+;; ;; TODO 2023-09-05: wrap, document, optimize, hack
9.36+;; (reexport-from :sb-int :include '(:awhen :acond))
9.37+
9.38+(defmacro! nlet-tail (n letargs &body body)
9.39+ (let ((gs (loop for i in letargs
9.40+ collect (gensym))))
9.41+ `(macrolet
9.42+ ((,n ,gs
9.43+ `(progn
9.44+ (psetq
9.45+ ,@(apply #'nconc
9.46+ (mapcar
9.47+ #'list
9.48+ ',(mapcar #'car letargs)
9.49+ (list ,@gs))))
9.50+ (go ,',g!n))))
9.51+ (block ,g!b
9.52+ (let ,letargs
9.53+ (tagbody
9.54+ ,g!n (return-from
9.55+ ,g!b (progn ,@body))))))))
9.56+
9.57+(defmacro alet% (letargs &rest body)
9.58+ `(let ((this) ,@letargs)
9.59+ (setq this ,@(last body))
9.60+ ,@(butlast body)
9.61+ this))
9.62+
9.63+(defmacro alet (letargs &rest body)
9.64+ `(let ((this) ,@letargs)
9.65+ (setq this ,@(last body))
9.66+ ,@(butlast body)
9.67+ (lambda (&rest params)
9.68+ (apply this params))))
9.69+
9.70+;; swiped from fiveam. This is just like acond except it assumes that
9.71+;; the TEST in each element of CLAUSES returns two values as opposed
9.72+;; to one.
9.73+(defmacro acond2 (&rest clauses)
9.74+ (if (null clauses)
9.75+ nil
9.76+ (with-gensyms (val foundp)
9.77+ (destructuring-bind ((test &rest progn) &rest others)
9.78+ clauses
9.79+ `(multiple-value-bind (,val ,foundp)
9.80+ ,test
9.81+ (if (or ,val ,foundp)
9.82+ (let ((it ,val))
9.83+ (declare (ignorable it))
9.84+ ,@progn)
9.85+ (acond2 ,@others)))))))
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/lisp/std/cond.lisp Mon Oct 16 19:33:42 2023 -0400
10.3@@ -0,0 +1,184 @@
10.4+;;; cond.lisp --- Conditions
10.5+
10.6+;;; Code:
10.7+(defpackage :std/cond
10.8+ (:use :cl)
10.9+ (:nicknames :cond)
10.10+ (:export
10.11+ #:nyi!
10.12+ #:required-argument
10.13+ #:ignore-some-conditions
10.14+ #:simple-style-warning
10.15+ #:simple-reader-error
10.16+ #:simple-parse-error
10.17+ #:simple-program-error
10.18+ #:circular-dependency
10.19+ #:circular-dependency-items
10.20+ #:unknown-argument
10.21+ #:unknown-argument-name
10.22+ #:unknown-argument-kind
10.23+ #:unknown-argument-p
10.24+ #:missing-argument
10.25+ #:missing-argument-command
10.26+ #:missing-argument-p
10.27+ #:invalid-argument
10.28+ #:invalid-argument-item
10.29+ #:invalid-argument-reason
10.30+ #:invalid-argument-p
10.31+ #:unwind-protect-case))
10.32+
10.33+(in-package :cond)
10.34+
10.35+(defmacro nyi! (&optional comment)
10.36+ `(prog1
10.37+ (error "Not Yet Implemented!")
10.38+ (when ',comment (print ',comment))))
10.39+
10.40+(defun required-argument (&optional name)
10.41+ "Signals an error for a missing argument of NAME. Intended for
10.42+use as an initialization form for structure and class-slots, and
10.43+a default value for required keyword arguments."
10.44+ (error "Required argument ~@[~S ~]missing." name))
10.45+
10.46+(define-condition simple-style-warning (simple-warning style-warning)
10.47+ ())
10.48+
10.49+(defun simple-style-warning (message &rest args)
10.50+ (warn 'simple-style-warning :format-control message :format-arguments args))
10.51+
10.52+;; We don't specify a :report for simple-reader-error to let the
10.53+;; underlying implementation report the line and column position for
10.54+;; us. Unfortunately this way the message from simple-error is not
10.55+;; displayed, unless there's special support for that in the
10.56+;; implementation. But even then it's still inspectable from the
10.57+;; debugger...
10.58+(define-condition simple-reader-error
10.59+ (sb-int:simple-reader-error)
10.60+ ())
10.61+
10.62+(defun simple-reader-error (stream message &rest args)
10.63+ (error 'simple-reader-error
10.64+ :stream stream
10.65+ :format-control message
10.66+ :format-arguments args))
10.67+
10.68+(define-condition simple-parse-error (simple-error parse-error)
10.69+ ())
10.70+
10.71+(defun simple-parse-error (message &rest args)
10.72+ (error 'simple-parse-error
10.73+ :format-control message
10.74+ :format-arguments args))
10.75+
10.76+(define-condition simple-program-error (simple-error program-error)
10.77+ ())
10.78+
10.79+(defun simple-program-error (message &rest args)
10.80+ (error 'simple-program-error
10.81+ :format-control message
10.82+ :format-arguments args))
10.83+
10.84+(define-condition circular-dependency (simple-error)
10.85+ ((items
10.86+ :initarg :items
10.87+ :initform (error "Must specify items")
10.88+ :reader circular-dependency-items))
10.89+ (:report (lambda (condition stream)
10.90+ (declare (ignore condition))
10.91+ (format stream "Circular dependency detected")))
10.92+ (:documentation "A condition which is signalled when a circular dependency is encountered."))
10.93+
10.94+(define-condition unknown-argument (error)
10.95+ ((name
10.96+ :initarg :name
10.97+ :initform (error "Must specify argument name")
10.98+ :reader unknown-argument-name)
10.99+ (kind
10.100+ :initarg :kind
10.101+ :initform (error "Must specify argument kind")
10.102+ :reader unknown-argument-kind))
10.103+ (:report (lambda (condition stream)
10.104+ (format stream "Unknown argument ~A of kind ~A"
10.105+ (unknown-argument-name condition)
10.106+ (unknown-argument-kind condition))))
10.107+ (:documentation "A condition which is signalled when an unknown argument is encountered."))
10.108+
10.109+(defun unknown-argument-p (value)
10.110+ (typep value 'unknown-argument))
10.111+
10.112+(define-condition missing-argument (simple-error)
10.113+ ((item
10.114+ :initarg :item
10.115+ :initform (error "Must specify argument item")
10.116+ :reader missing-argument-item)
10.117+ (command
10.118+ :initarg :command
10.119+ :initform (error "Must specify command")
10.120+ :reader missing-argument-command))
10.121+ (:report (lambda (condition stream)
10.122+ (declare (ignore condition))
10.123+ (format stream "Missing argument")))
10.124+ (:documentation "A condition which is signalled when an option expects an argument, but none was provided"))
10.125+
10.126+(defun missing-argument-p (value)
10.127+ (typep value 'missing-argument))
10.128+
10.129+(define-condition invalid-argument (simple-error)
10.130+ ((item
10.131+ :initarg :item
10.132+ :initform (error "Must specify argument item")
10.133+ :reader invalid-argument-item
10.134+ :documentation "The argument which is identified as invalid")
10.135+ (reason
10.136+ :initarg :reason
10.137+ :initform (error "Must specify reason")
10.138+ :reader invalid-argument-reason
10.139+ :documentation "The reason why this argument is invalid"))
10.140+ (:report (lambda (condition stream)
10.141+ (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition))))
10.142+ (:documentation "A condition which is signalled when an argument is identified as invalid."))
10.143+
10.144+(defmacro ignore-some-conditions ((&rest conditions) &body body)
10.145+ "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
10.146+list determines which specific conditions are to be ignored."
10.147+ `(handler-case
10.148+ (progn ,@body)
10.149+ ,@(loop for condition in conditions collect
10.150+ `(,condition (c) (values nil c)))))
10.151+
10.152+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
10.153+ "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
10.154+the cleanup CLAUSES are run.
10.155+
10.156+ clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
10.157+
10.158+Clauses can be given in any order, and more than one clause can be
10.159+given for each circumstance. The clauses whose denoted circumstance
10.160+occured, are executed in the order the clauses appear.
10.161+
10.162+ABORT-FLAG is the name of a variable that will be bound to T in
10.163+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
10.164+otherwise.
10.165+
10.166+Examples:
10.167+
10.168+ (unwind-protect-case ()
10.169+ (protected-form)
10.170+ (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
10.171+ (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
10.172+ (:always (format t \"This is evaluated in either case.~%\")))
10.173+
10.174+ (unwind-protect-case (aborted-p)
10.175+ (protected-form)
10.176+ (:always (perform-cleanup-if aborted-p)))
10.177+"
10.178+ (check-type abort-flag (or null symbol))
10.179+ (let ((gflag (gensym "FLAG+")))
10.180+ `(let ((,gflag t))
10.181+ (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
10.182+ (let ,(and abort-flag `((,abort-flag ,gflag)))
10.183+ ,@(loop for (cleanup-kind . forms) in clauses
10.184+ collect (ecase cleanup-kind
10.185+ (:normal `(when (not ,gflag) ,@forms))
10.186+ (:abort `(when ,gflag ,@forms))
10.187+ (:always `(progn ,@forms)))))))))
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/lisp/std/fmt.lisp Mon Oct 16 19:33:42 2023 -0400
11.3@@ -0,0 +1,168 @@
11.4+;;; std/fmt.lisp --- printer and format utils
11.5+
11.6+;;; Code:
11.7+(defpackage :std/fmt
11.8+ (:nicknames :fmt)
11.9+ (:use :cl :str :fu :list)
11.10+ (:import-from :uiop :println)
11.11+ (:export :printer-status :fmt-row :fmt-sxhash :iprintln :fmt-tree))
11.12+
11.13+(in-package :fmt)
11.14+
11.15+(defun iprintln (x &optional (n 2) stream)
11.16+ (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream))
11.17+
11.18+(defun printer-status ()
11.19+ (format t ";; *print-array* = ~a~%" *print-array*)
11.20+ (format t ";; *print-base* = ~a~%" *print-base*)
11.21+ (format t ";; *print-case* = ~a~%" *print-case*)
11.22+ (format t ";; *print-circle* = ~a~%" *print-circle*)
11.23+ (format t ";; *print-escape* = ~a~%" *print-escape*)
11.24+ (format t ";; *print-gensym* = ~a~%" *print-gensym*)
11.25+ (format t ";; *print-length* = ~a~%" *print-length*)
11.26+ (format t ";; *print-level* = ~a~%" *print-level*)
11.27+ (format t ";; *print-lines* = ~a~%" *print-lines*)
11.28+ (format t ";; *print-miser-width* = ~a~%" *print-miser-width*)
11.29+ (format t ";; *print-pprint-dispatch* = ~a~%" *print-pprint-dispatch*)
11.30+ (format t ";; *print-pretty* = ~a~%" *print-pretty*)
11.31+ (format t ";; *print-radix* = ~a~%" *print-radix*)
11.32+ (format t ";; *print-readably* = ~a~%" *print-readably*)
11.33+ (format t ";; *print-right-margin* = ~a~%" *print-right-margin*))
11.34+
11.35+;;; Tables
11.36+(defun fmt-row (data)
11.37+ (format nil "| ~{~A~^ | ~} |~%" data))
11.38+
11.39+;;; IDs
11.40+(defun fmt-sxhash (code)
11.41+ "Turn the fixnum value CODE into a human-friendly string. CODE should
11.42+be produced by `sxhash'."
11.43+ (let (r)
11.44+ (dotimes (i 8 r)
11.45+ (push (ldb (byte 8 (* i 8)) code) r))
11.46+ (format
11.47+ nil
11.48+ "~{~A~^-~}"
11.49+ (mapcar
11.50+ (lambda (x) (format nil "~{~(~2,'0x~)~}" x))
11.51+ (group r 2)))))
11.52+
11.53+;;; ASCII
11.54+
11.55+;;;; Trees
11.56+
11.57+;; from https://gist.github.com/WetHat/9682b8f70f0241c37cd5d732784d1577
11.58+
11.59+;; Example:
11.60+
11.61+;; (let ((tree '(A B1 B2 (B3 C1) C2)))
11.62+;; ; enumerate all layout options and draw the tree for each one.
11.63+;; (dolist (layout '(:up :centered :down))
11.64+;; (format t "Layout = :~A~%" layout)
11.65+;; (fmt-tree t tree :layout layout)))
11.66+
11.67+;; Layout = :UP
11.68+;; ╭─ C2
11.69+;; │ ╭─ C1
11.70+;; ├─ B3
11.71+;; ├─ B2
11.72+;; ├─ B1
11.73+;; A
11.74+;; Layout = :CENTERED
11.75+;; ╭─ B2
11.76+;; ├─ B1
11.77+;; A
11.78+;; ├─ B3
11.79+;; │ ╰─ C1
11.80+;; ╰─ C2
11.81+;; Layout = :DOWN
11.82+;; A
11.83+;; ├─ B1
11.84+;; ├─ B2
11.85+;; ├─ B3
11.86+;; │ ╰─ C1
11.87+;; ╰─ C2
11.88+
11.89+;; Unicode plain ASCII representation
11.90+(defvar *space* " ")
11.91+(defvar *upper-knee* " ╭─ ") ; " .- "
11.92+(defvar *pipe* " │ ") ; " | "
11.93+(defvar *tee* " ├─ ") ; " +- "
11.94+(defvar *lower-knee* " ╰─ ") ; " '- "
11.95+
11.96+(defun format-tree-segments (node &key (layout :centered)
11.97+ (node-formatter #'write-to-string))
11.98+ (unless node
11.99+ (return-from format-tree-segments nil)) ; nothing to do here
11.100+ (setq node (ensure-cons node))
11.101+ (flet ((prefix-node-strings (child-node &key layout node-formatter
11.102+ (upper-connector *pipe*)
11.103+ (root-connector *tee*)
11.104+ (lower-connector *pipe*))
11.105+ "A local utility to add connectors to a string representation
11.106+ of a tree segment to connect it to other tree segments."
11.107+ (multiple-value-bind (u r l)
11.108+ (format-tree-segments child-node
11.109+ :layout layout
11.110+ :node-formatter node-formatter)
11.111+ ; prefix tree segment with connector glyphs to connect it to
11.112+ ; other segments.
11.113+ (nconc
11.114+ (mapcar
11.115+ (lambda (str) (concatenate 'string upper-connector str))
11.116+ u)
11.117+ (list (concatenate 'string root-connector r))
11.118+ (mapcar
11.119+ (lambda (str) (concatenate 'string lower-connector str))
11.120+ l)))))
11.121+ (let* ((children (rest node))
11.122+ (pivot (case layout ; the split point of the list of children
11.123+ (:up (length children)) ; split at top
11.124+ (:down 0) ; split at bottom
11.125+ (otherwise (round (/ (length children) 2))))) ; bisect
11.126+ (upper-children (reverse (subseq children 0 pivot))) ; above root
11.127+ (lower-children (subseq children pivot))) ; nodes below root
11.128+ (values ; compile multiple value return of upper-children root lower children
11.129+ (when upper-children
11.130+ (loop with top = (prefix-node-strings (first upper-children)
11.131+ :layout layout
11.132+ :node-formatter node-formatter
11.133+ :upper-connector *space*
11.134+ :root-connector *upper-knee*) ; top node has special connectors
11.135+ for child-node in (rest upper-children)
11.136+ nconc (prefix-node-strings child-node
11.137+ :layout layout
11.138+ :node-formatter node-formatter)
11.139+ into strlist
11.140+ finally (return (nconc top strlist))))
11.141+ (let ((root-name (funcall node-formatter (car node)))) ; root node
11.142+ (if (= 1 (length root-name))
11.143+ (concatenate 'string " " root-name) ; at least 2 chars needed
11.144+ ;else
11.145+ root-name))
11.146+ (when lower-children
11.147+ (loop for (head . tail) on lower-children
11.148+ while tail ; omit the last child
11.149+ nconc (prefix-node-strings head
11.150+ :layout layout
11.151+ :node-formatter node-formatter)
11.152+ into strlist
11.153+ finally (return
11.154+ (nconc
11.155+ strlist
11.156+ ; bottom node has special connectors
11.157+ (prefix-node-strings head
11.158+ :layout layout
11.159+ :node-formatter node-formatter
11.160+ :root-connector *lower-knee*
11.161+ :lower-connector *space*)))))))))
11.162+
11.163+(defun fmt-tree (stream root &key
11.164+ (plist nil)
11.165+ (layout :centered)
11.166+ (node-formatter #'write-to-string))
11.167+ (multiple-value-bind (u r l)
11.168+ (format-tree-segments (if plist (cons (car root) (group (cdr root) 2)) root)
11.169+ :layout layout
11.170+ :node-formatter node-formatter)
11.171+ (format stream "~{~A~%~}" (nconc u (list r) l))))
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/std/fs.lisp Mon Oct 16 19:33:42 2023 -0400
12.3@@ -0,0 +1,16 @@
12.4+;;; std/fs.lisp --- Filesystem utils
12.5+
12.6+;; TODO
12.7+
12.8+;;; Commentary:
12.9+
12.10+;; I think PN has a 'portable pathname library' in PAICL or
12.11+;; something. oldie but goodie for reference.
12.12+
12.13+;;; Code:
12.14+(defpackage :std/fs
12.15+ (:nicknames :fs)
12.16+ (:use :cl :str :cond :fu)
12.17+ (:export))
12.18+
12.19+(in-package :fs)
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/lisp/std/fu.lisp Mon Oct 16 19:33:42 2023 -0400
13.3@@ -0,0 +1,968 @@
13.4+;;; fu.lisp --- Function utilities
13.5+
13.6+;;; Code:
13.7+(defpackage :std/fu
13.8+ (:nicknames :fu)
13.9+ (:use :cl :sb-mop :sb-c :named-readtables :sym :list :cond)
13.10+ (:export
13.11+ :until
13.12+ #:mkstr
13.13+ #:symb
13.14+ #:group
13.15+ #:flatten
13.16+ #:fact
13.17+ #:choose
13.18+ #:g!-symbol-p
13.19+ #:defmacro/g!
13.20+ #:o!-symbol-p
13.21+ #:o!-symbol-to-g!-symbol
13.22+ #:defmacro!
13.23+ #:defun!
13.24+ #:|#"-reader|
13.25+ #:|#`-reader|
13.26+ #:|#f-reader|
13.27+ #:|#$-reader|
13.28+ #:segment-reader
13.29+ #:match-mode-ppcre-lambda-form
13.30+ #:subst-mode-ppcre-lambda-form
13.31+ #+cl-ppcre #:|#~-reader|
13.32+ #:dlambda
13.33+ #:make-tlist
13.34+ #:tlist-left
13.35+ #:tlist-right
13.36+ #:tlist-empty-p
13.37+ #:tlist-add-left
13.38+ #:tlist-add-right
13.39+ #:tlist-rem-left
13.40+ #:tlist-update
13.41+ #:build-batcher-sn
13.42+ #:sortf
13.43+ #:dollar-symbol-p
13.44+ #:if-match
13.45+ #:when-match
13.46+ #:once-only
13.47+ #:destructuring-case
13.48+ #:destructuring-ccase
13.49+ #:destructuring-ecase
13.50+ #:when-let
13.51+ #:when-let*
13.52+ #:if-let
13.53+ #:if-let*
13.54+ :define-constant
13.55+ :def!
13.56+ :eval-always
13.57+ :merge! :sort!
13.58+ :list-slot-values-using-class :list-class-methods :list-class-slots :list-indirect-slot-methods))
13.59+
13.60+(in-package :fu)
13.61+
13.62+;;; Misc
13.63+(defmacro until (condition &body body)
13.64+ (let ((block-name (gensym)))
13.65+ `(block ,block-name
13.66+ (loop
13.67+ (if ,condition
13.68+ (return-from ,block-name nil)
13.69+ (progn ,@body))))))
13.70+
13.71+;;; From LOL
13.72+
13.73+(defun group (source n)
13.74+ (when (zerop n) (error "zero length"))
13.75+ (labels ((rec (source acc)
13.76+ (let ((rest (nthcdr n source)))
13.77+ (if (consp rest)
13.78+ (rec rest (cons
13.79+ (subseq source 0 n)
13.80+ acc))
13.81+ (nreverse
13.82+ (cons source acc))))))
13.83+ (if source (rec source nil) nil)))
13.84+
13.85+(eval-when (:compile-toplevel :execute :load-toplevel)
13.86+ (defun mkstr (&rest args)
13.87+ (with-output-to-string (s)
13.88+ (dolist (a args) (princ a s))))
13.89+
13.90+ (defun symb (&rest args)
13.91+ (values (intern (apply #'mkstr args))))
13.92+
13.93+ (defun flatten (x)
13.94+ (labels ((rec (x acc)
13.95+ (cond ((null x) acc)
13.96+ #+sbcl
13.97+ ((typep x 'sb-impl::comma) (rec (sb-impl::comma-expr x) acc))
13.98+ ((atom x) (cons x acc))
13.99+ (t (rec
13.100+ (car x)
13.101+ (rec (cdr x) acc))))))
13.102+ (rec x nil)))
13.103+
13.104+ (defun g!-symbol-p (s)
13.105+ (and (symbolp s)
13.106+ (> (length (symbol-name s)) 2)
13.107+ (string= (symbol-name s)
13.108+ "G!"
13.109+ :start1 0
13.110+ :end1 2)))
13.111+
13.112+ (defun o!-symbol-p (s)
13.113+ (and (symbolp s)
13.114+ (> (length (symbol-name s)) 2)
13.115+ (string= (symbol-name s)
13.116+ "O!"
13.117+ :start1 0
13.118+ :end1 2)))
13.119+
13.120+ (defun o!-symbol-to-g!-symbol (s)
13.121+ (symb "G!"
13.122+ (subseq (symbol-name s) 2))))
13.123+
13.124+(defmacro defmacro/g! (name args &rest body)
13.125+ (let ((syms (remove-duplicates
13.126+ (remove-if-not #'g!-symbol-p
13.127+ (flatten body)))))
13.128+ (multiple-value-bind (body declarations docstring)
13.129+ (parse-body body :documentation t)
13.130+ `(defmacro ,name ,args
13.131+ ,@(when docstring
13.132+ (list docstring))
13.133+ ,@declarations
13.134+ (let ,(mapcar
13.135+ (lambda (s)
13.136+ `(,s (gensym ,(subseq
13.137+ (symbol-name s)
13.138+ 2))))
13.139+ syms)
13.140+ ,@body)))))
13.141+
13.142+(defmacro defmacro! (name args &rest body)
13.143+ (let* ((os (remove-if-not #'o!-symbol-p (flatten args)))
13.144+ (gs (mapcar #'o!-symbol-to-g!-symbol os)))
13.145+ (multiple-value-bind (body declarations docstring)
13.146+ (parse-body body :documentation t)
13.147+ `(defmacro/g! ,name ,args
13.148+ ,@(when docstring
13.149+ (list docstring))
13.150+ ,@declarations
13.151+ `(let ,(mapcar #'list (list ,@gs) (list ,@os))
13.152+ ,(progn ,@body))))))
13.153+
13.154+(defmacro defun! (name args &body body)
13.155+ (let ((syms (remove-duplicates
13.156+ (remove-if-not #'g!-symbol-p
13.157+ (flatten body)))))
13.158+ (multiple-value-bind (body declarations docstring)
13.159+ (parse-body body :documentation t)
13.160+ `(defun ,name ,args
13.161+ ,@(when docstring
13.162+ (list docstring))
13.163+ ,@declarations
13.164+ (let ,(mapcar (lambda (s)
13.165+ `(,s (gensym ,(subseq (symbol-name s)
13.166+ 2))))
13.167+ syms)
13.168+ ,@body)))))
13.169+
13.170+(eval-when (:compile-toplevel :execute :load-toplevel)
13.171+ (defun |#`-reader| (stream sub-char numarg)
13.172+ (declare (ignore sub-char))
13.173+ (unless numarg (setq numarg 1))
13.174+ `(lambda ,(loop for i from 1 to numarg
13.175+ collect (symb 'a i))
13.176+ ,(funcall
13.177+ (get-macro-character #\`) stream nil)))
13.178+
13.179+ (defun |#f-reader| (stream sub-char numarg)
13.180+ (declare (ignore stream sub-char))
13.181+ (setq numarg (or numarg 3))
13.182+ (unless (<= numarg 3)
13.183+ (error "Bad value for #f: ~a" numarg))
13.184+ `(declare (optimize (speed ,numarg)
13.185+ (safety ,(- 3 numarg)))))
13.186+
13.187+ (defun |#$-reader| (stream sub-char numarg)
13.188+ "Switch on the shell reader, parsing STREAM and returning a
13.189+POSIX-compliant shell program as a string. In other words, this is an
13.190+implementation of the lazy version of SHCL's #$-reader.
13.191+
13.192+Similar to shcl, we add some reader extensions to enable embedding
13.193+lisp forms and other goodies.
13.194+
13.195+#$ x=,(* 2 2)
13.196+echo $x
13.197+$#
13.198+;; => 4"
13.199+ (declare (ignore sub-char numarg))
13.200+ (let (chars (state 'sh))
13.201+ (loop do
13.202+ (let ((c (read-char stream)))
13.203+ (cond
13.204+ ((eq state 'sh)
13.205+ (when (char= c #\$) (setq state 'dolla))
13.206+ (push c chars))
13.207+ ((eq state 'dolla)
13.208+ (cond
13.209+ ((char= c #\#)
13.210+ ;; remove trailing '$'
13.211+ (pop chars)
13.212+ (return))
13.213+ (t (setq state 'sh) (push c chars)))))))
13.214+ (coerce (nreverse chars) 'string))))
13.215+
13.216+;; Nestable suggestion from Daniel Herring
13.217+(eval-when (:compile-toplevel :load-toplevel :execute)
13.218+ (defun |#"-reader| (stream sub-char numarg)
13.219+ (declare (ignore sub-char numarg))
13.220+ (let (chars (state 'normal) (depth 1))
13.221+ (loop do
13.222+ (let ((curr (read-char stream)))
13.223+ (cond ((eq state 'normal)
13.224+ (cond ((char= curr #\#)
13.225+ (push #\# chars)
13.226+ (setq state 'read-sharp))
13.227+ ((char= curr #\")
13.228+ (setq state 'read-quote))
13.229+ (t
13.230+ (push curr chars))))
13.231+ ((eq state 'read-sharp)
13.232+ (cond ((char= curr #\")
13.233+ (push #\" chars)
13.234+ (incf depth)
13.235+ (setq state 'normal))
13.236+ (t
13.237+ (push curr chars)
13.238+ (setq state 'normal))))
13.239+ ((eq state 'read-quote)
13.240+ (cond ((char= curr #\#)
13.241+ (decf depth)
13.242+ (if (zerop depth) (return))
13.243+ (push #\" chars)
13.244+ (push #\# chars)
13.245+ (setq state 'normal))
13.246+ (t
13.247+ (push #\" chars)
13.248+ (if (char= curr #\")
13.249+ (setq state 'read-quote)
13.250+ (progn
13.251+ (push curr chars)
13.252+ (setq state 'normal)))))))))
13.253+ (coerce (nreverse chars) 'string))))
13.254+
13.255+; This version is from Martin Dirichs
13.256+(eval-when (:compile-toplevel :load-toplevel :execute)
13.257+ (defun |#>-reader| (stream sub-char numarg)
13.258+ (declare (ignore sub-char numarg))
13.259+ (let (chars)
13.260+ (do ((curr (read-char stream)
13.261+ (read-char stream)))
13.262+ ((char= #\newline curr))
13.263+ (push curr chars))
13.264+ (let ((pattern (nreverse chars))
13.265+ output)
13.266+ (labels ((match (pos chars)
13.267+ (if (null chars)
13.268+ pos
13.269+ (if (char= (nth pos pattern) (car chars))
13.270+ (match (1+ pos) (cdr chars))
13.271+ (match 0 (cdr (append (subseq pattern 0 pos) chars)))))))
13.272+ (do (curr
13.273+ (pos 0))
13.274+ ((= pos (length pattern)))
13.275+ (setf curr (read-char stream)
13.276+ pos (match pos (list curr)))
13.277+ (push curr output))
13.278+ (coerce
13.279+ (nreverse
13.280+ (nthcdr (length pattern) output))
13.281+ 'string))))))
13.282+
13.283+; (set-dispatch-macro-character #\# #\> #'|#>-reader|)
13.284+
13.285+(defun segment-reader (stream ch n)
13.286+ (if (> n 0)
13.287+ (let ((chars))
13.288+ (do ((curr (read-char stream)
13.289+ (read-char stream)))
13.290+ ((char= ch curr))
13.291+ (push curr chars))
13.292+ (cons (coerce (nreverse chars) 'string)
13.293+ (segment-reader stream ch (- n 1))))))
13.294+
13.295+#+cl-ppcre
13.296+(defmacro! match-mode-ppcre-lambda-form (o!args o!mods)
13.297+ ``(lambda (,',g!str)
13.298+ (cl-ppcre:scan-to-strings
13.299+ ,(if (zerop (length ,g!mods))
13.300+ (car ,g!args)
13.301+ (format nil "(?~a)~a" ,g!mods (car ,g!args)))
13.302+ ,',g!str)))
13.303+
13.304+#+cl-ppcre
13.305+(defmacro! subst-mode-ppcre-lambda-form (o!args)
13.306+ ``(lambda (,',g!str)
13.307+ (cl-ppcre:regex-replace-all
13.308+ ,(car ,g!args)
13.309+ ,',g!str
13.310+ ,(cadr ,g!args))))
13.311+
13.312+#+cl-ppcre
13.313+(eval-when (:compile-toplevel :load-toplevel :execute)
13.314+ (defun |#~-reader| (stream sub-char numarg)
13.315+ (declare (ignore sub-char numarg))
13.316+ (let ((mode-char (read-char stream)))
13.317+ (cond
13.318+ ((char= mode-char #\m)
13.319+ (match-mode-ppcre-lambda-form
13.320+ (segment-reader stream
13.321+ (read-char stream)
13.322+ 1)
13.323+ (coerce (loop for c = (read-char stream)
13.324+ while (alpha-char-p c)
13.325+ collect c
13.326+ finally (unread-char c stream))
13.327+ 'string)))
13.328+ ((char= mode-char #\s)
13.329+ (subst-mode-ppcre-lambda-form
13.330+ (segment-reader stream
13.331+ (read-char stream)
13.332+ 2)))
13.333+ (t (error "Unknown #~~ mode character"))))))
13.334+
13.335+#+cl-ppcre (set-dispatch-macro-character #\# #\~ #'|#~-reader|)
13.336+
13.337+(eval-when (:compile-toplevel :load-toplevel :execute)
13.338+(defreadtable :std
13.339+ (:merge :modern)
13.340+ (:dispatch-macro-char #\# #\" #'|#"-reader|)
13.341+ (:dispatch-macro-char #\# #\> #'|#>-reader|)
13.342+ #+cl-ppcre (:dispatch-macro-char #\# #\~ #'|#~-reader|)
13.343+ (:dispatch-macro-char #\# #\` #'|#`-reader|)
13.344+ (:dispatch-macro-char #\# #\f #'|#f-reader|)
13.345+ (:dispatch-macro-char #\# #\$ #'|#$-reader|)))
13.346+
13.347+(defmacro! dlambda (&rest ds)
13.348+ "Dynamic dispatch lambda."
13.349+ `(lambda (&rest ,g!args)
13.350+ (case (car ,g!args)
13.351+ ,@(mapcar
13.352+ (lambda (d)
13.353+ `(,(if (eq t (car d))
13.354+ t
13.355+ (list (car d)))
13.356+ (apply (lambda ,@(cdr d))
13.357+ ,(if (eq t (car d))
13.358+ g!args
13.359+ `(cdr ,g!args)))))
13.360+ ds))))
13.361+
13.362+(declaim (inline make-tlist tlist-left
13.363+ tlist-right tlist-empty-p))
13.364+
13.365+(defun make-tlist () (cons nil nil))
13.366+(defun tlist-left (tl) (caar tl))
13.367+(defun tlist-right (tl) (cadr tl))
13.368+(defun tlist-empty-p (tl) (null (car tl)))
13.369+
13.370+(declaim (inline tlist-add-left
13.371+ tlist-add-right))
13.372+
13.373+(defun tlist-add-left (tl it)
13.374+ (let ((x (cons it (car tl))))
13.375+ (if (tlist-empty-p tl)
13.376+ (setf (cdr tl) x))
13.377+ (setf (car tl) x)))
13.378+
13.379+(defun tlist-add-right (tl it)
13.380+ (let ((x (cons it nil)))
13.381+ (if (tlist-empty-p tl)
13.382+ (setf (car tl) x)
13.383+ (setf (cddr tl) x))
13.384+ (setf (cdr tl) x)))
13.385+
13.386+(declaim (inline tlist-rem-left))
13.387+
13.388+(defun tlist-rem-left (tl)
13.389+ (if (tlist-empty-p tl)
13.390+ (error "Remove from empty tlist")
13.391+ (let ((x (car tl)))
13.392+ (setf (car tl) (cdar tl))
13.393+ (if (tlist-empty-p tl)
13.394+ (setf (cdr tl) nil)) ;; For gc
13.395+ (car x))))
13.396+
13.397+(declaim (inline tlist-update))
13.398+
13.399+(defun tlist-update (tl)
13.400+ (setf (cdr tl) (last (car tl))))
13.401+
13.402+(defun build-batcher-sn (n)
13.403+ (let* (network
13.404+ (tee (ceiling (log n 2)))
13.405+ (p (ash 1 (- tee 1))))
13.406+ (loop while (> p 0) do
13.407+ (let ((q (ash 1 (- tee 1)))
13.408+ (r 0)
13.409+ (d p))
13.410+ (loop while (> d 0) do
13.411+ (loop for i from 0 to (- n d 1) do
13.412+ (if (= (logand i p) r)
13.413+ (push (list i (+ i d))
13.414+ network)))
13.415+ (setf d (- q p)
13.416+ q (ash q -1)
13.417+ r p)))
13.418+ (setf p (ash p -1)))
13.419+ (nreverse network)))
13.420+
13.421+(in-readtable :std)
13.422+
13.423+(defmacro! sortf (comparator &rest places)
13.424+ (if places
13.425+ `(tagbody
13.426+ ,@(mapcar
13.427+ #`(let ((,g!a #1=,(nth (car a1) places))
13.428+ (,g!b #2=,(nth (cadr a1) places)))
13.429+ (if (,comparator ,g!b ,g!a)
13.430+ (setf #1# ,g!b
13.431+ #2# ,g!a)))
13.432+ (build-batcher-sn (length places))))))
13.433+
13.434+#+cl-ppcre
13.435+(defun dollar-symbol-p (s)
13.436+ (and (symbolp s)
13.437+ (> (length (symbol-name s)) 1)
13.438+ (string= (symbol-name s)
13.439+ "$"
13.440+ :start1 0
13.441+ :end1 1)
13.442+ (ignore-errors (parse-integer (subseq (symbol-name s) 1)))))
13.443+
13.444+
13.445+#+cl-ppcre
13.446+(defmacro! if-match ((match-regex str) then &optional else)
13.447+ (let* ((dollars (remove-duplicates
13.448+ (remove-if-not #'dollar-symbol-p
13.449+ (flatten then))))
13.450+ (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>))
13.451+ 0)))
13.452+ `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str)
13.453+ (declare (ignorable ,g!matches ,g!captures))
13.454+ (let ((,g!captures-len (length ,g!captures)))
13.455+ (declare (ignorable ,g!captures-len))
13.456+ (symbol-macrolet ,(mapcar #`(,(symb "$" a1)
13.457+ (if (< ,g!captures-len ,a1)
13.458+ (error "Too few matchs: ~a unbound." ,(mkstr "$" a1))
13.459+ (aref ,g!captures ,(1- a1))))
13.460+ (loop for i from 1 to top collect i))
13.461+ (if ,g!matches
13.462+ ,then
13.463+ ,else))))))
13.464+
13.465+#+cl-ppcre
13.466+(defmacro when-match ((match-regex str) &body forms)
13.467+ `(if-match (,match-regex ,str)
13.468+ (progn ,@forms)))
13.469+
13.470+(defmacro once-only (specs &body forms)
13.471+ "Constructs code whose primary goal is to help automate the handling of
13.472+multiple evaluation within macros. Multiple evaluation is handled by introducing
13.473+intermediate variables, in order to reuse the result of an expression.
13.474+
13.475+The returned value is a list of the form
13.476+
13.477+ (let ((<gensym-1> <expr-1>)
13.478+ ...
13.479+ (<gensym-n> <expr-n>))
13.480+ <res>)
13.481+
13.482+where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
13.483+to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
13.484+evaluating the implicit progn FORMS within a special context determined by
13.485+SPECS. RES should make use of (reference) the intermediate variables.
13.486+
13.487+Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
13.488+Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
13.489+
13.490+Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
13.491+
13.492+- INITFORM is an expression evaluated to produce EXPR-i
13.493+
13.494+- SYMBOL is the name of the variable that will be bound around FORMS to the
13.495+ corresponding gensym GENSYM-i, in order for FORMS to generate RES that
13.496+ references the intermediate variable
13.497+
13.498+The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
13.499+all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
13.500+
13.501+Example:
13.502+
13.503+ The following expression
13.504+
13.505+ (let ((x '(incf y)))
13.506+ (once-only (x)
13.507+ `(cons ,x ,x)))
13.508+
13.509+ ;;; =>
13.510+ ;;; (let ((#1=#:X123 (incf y)))
13.511+ ;;; (cons #1# #1#))
13.512+
13.513+ could be used within a macro to avoid multiple evaluation like so
13.514+
13.515+ (defmacro cons1 (x)
13.516+ (once-only (x)
13.517+ `(cons ,x ,x)))
13.518+
13.519+ (let ((y 0))
13.520+ (cons1 (incf y)))
13.521+
13.522+ ;;; => (1 . 1)
13.523+
13.524+Example:
13.525+
13.526+ The following expression demonstrates the usage of the INITFORM field
13.527+
13.528+ (let ((expr '(incf y)))
13.529+ (once-only ((var `(1+ ,expr)))
13.530+ `(list ',expr ,var ,var)))
13.531+
13.532+ ;;; =>
13.533+ ;;; (let ((#1=#:VAR123 (1+ (incf y))))
13.534+ ;;; (list '(incf y) #1# #1))
13.535+
13.536+ which could be used like so
13.537+
13.538+ (defmacro print-succ-twice (expr)
13.539+ (once-only ((var `(1+ ,expr)))
13.540+ `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
13.541+
13.542+ (let ((y 10))
13.543+ (print-succ-twice (incf y)))
13.544+
13.545+ ;;; >>
13.546+ ;;; Expr: (INCF Y), Once: 12, Twice: 12"
13.547+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
13.548+ (names-and-forms (mapcar (lambda (spec)
13.549+ (etypecase spec
13.550+ (list
13.551+ (destructuring-bind (name form) spec
13.552+ (cons name form)))
13.553+ (symbol
13.554+ (cons spec spec))))
13.555+ specs)))
13.556+ ;; bind in user-macro
13.557+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
13.558+ gensyms names-and-forms)
13.559+ ;; bind in final expansion
13.560+ `(let (,,@(mapcar (lambda (g n)
13.561+ ``(,,g ,,(cdr n)))
13.562+ gensyms names-and-forms))
13.563+ ;; bind in user-macro
13.564+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
13.565+ names-and-forms gensyms)
13.566+ ,@forms)))))
13.567+
13.568+;;;; DESTRUCTURING-*CASE
13.569+
13.570+(defun expand-destructuring-case (key clauses case)
13.571+ (once-only (key)
13.572+ `(if (typep ,key 'cons)
13.573+ (,case (car ,key)
13.574+ ,@(mapcar (lambda (clause)
13.575+ (destructuring-bind ((keys . lambda-list) &body body) clause
13.576+ `(,keys
13.577+ (destructuring-bind ,lambda-list (cdr ,key)
13.578+ ,@body))))
13.579+ clauses))
13.580+ (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
13.581+
13.582+(defmacro destructuring-case (keyform &body clauses)
13.583+ "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
13.584+KEYFORM must evaluate to a CONS.
13.585+
13.586+Clauses are of the form:
13.587+
13.588+ ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
13.589+
13.590+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
13.591+is selected, and FORMs are then executed with CDR of KEY is destructured and
13.592+bound by the DESTRUCTURING-LAMBDA-LIST.
13.593+
13.594+Example:
13.595+
13.596+ (defun dcase (x)
13.597+ (destructuring-case x
13.598+ ((:foo a b)
13.599+ (format nil \"foo: ~S, ~S\" a b))
13.600+ ((:bar &key a b)
13.601+ (format nil \"bar: ~S, ~S\" a b))
13.602+ (((:alt1 :alt2) a)
13.603+ (format nil \"alt: ~S\" a))
13.604+ ((t &rest rest)
13.605+ (format nil \"unknown: ~S\" rest))))
13.606+
13.607+ (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
13.608+ (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
13.609+ (dcase (list :alt1 1)) ; => \"alt: 1\"
13.610+ (dcase (list :alt2 2)) ; => \"alt: 2\"
13.611+ (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
13.612+
13.613+ (defun decase (x)
13.614+ (destructuring-case x
13.615+ ((:foo a b)
13.616+ (format nil \"foo: ~S, ~S\" a b))
13.617+ ((:bar &key a b)
13.618+ (format nil \"bar: ~S, ~S\" a b))
13.619+ (((:alt1 :alt2) a)
13.620+ (format nil \"alt: ~S\" a))))
13.621+
13.622+ (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
13.623+ (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
13.624+ (decase (list :alt1 1)) ; => \"alt: 1\"
13.625+ (decase (list :alt2 2)) ; => \"alt: 2\"
13.626+ (decase (list :quux 1 2 3)) ; =| error
13.627+"
13.628+ (expand-destructuring-case keyform clauses 'case))
13.629+
13.630+(defmacro destructuring-ccase (keyform &body clauses)
13.631+ (expand-destructuring-case keyform clauses 'ccase))
13.632+
13.633+(defmacro destructuring-ecase (keyform &body clauses)
13.634+ (expand-destructuring-case keyform clauses 'ecase))
13.635+
13.636+(dolist (name '(destructuring-ccase destructuring-ecase))
13.637+ (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
13.638+
13.639+;;; *-let --- control-flow let-binding macros
13.640+;; based on https://stevelosh.com/blog/2018/07/fun-with-macros-if-let/
13.641+
13.642+(defmacro when-let (bindings &body body)
13.643+ "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.
13.644+
13.645+ This macro combines `when` and `let`. It takes a list of bindings and
13.646+ binds them like `let` before executing `body`, but if any binding's value
13.647+ evaluates to `nil` the process stops and `nil` is immediately returned.
13.648+
13.649+ Examples:
13.650+
13.651+ (when-let ((a (progn (print :a) 1))
13.652+ (b (progn (print :b) 2))
13.653+ (list a b))
13.654+ ; =>
13.655+ :A
13.656+ :B
13.657+ (1 2)
13.658+
13.659+ (when-let ((a (progn (print :a) nil))
13.660+ (b (progn (print :b) 2)))
13.661+ (list a b))
13.662+ ; =>
13.663+ :A
13.664+ NIL
13.665+
13.666+ "
13.667+ (with-gensyms (block)
13.668+ `(block ,block
13.669+ (let ,(loop :for (symbol value) :in bindings
13.670+ :collect `(,symbol (or ,value
13.671+ (return-from ,block nil))))
13.672+ ,@body))))
13.673+
13.674+(defmacro when-let* (bindings &body body)
13.675+ "Bind `bindings` serially and execute `body`, short-circuiting on `nil`.
13.676+
13.677+ This macro combines `when` and `let*`. It takes a list of bindings
13.678+ and binds them like `let*` before executing `body`, but if any
13.679+ binding's value evaluates to `nil` the process stops and `nil` is
13.680+ immediately returned.
13.681+
13.682+ Examples:
13.683+
13.684+ (when-let* ((a (progn (print :a) 1))
13.685+ (b (progn (print :b) (1+ a)))
13.686+ (list a b))
13.687+ ; =>
13.688+ :A
13.689+ :B
13.690+ (1 2)
13.691+
13.692+ (when-let* ((a (progn (print :a) nil))
13.693+ (b (progn (print :b) (1+ a))))
13.694+ (list a b))
13.695+ ; =>
13.696+ :A
13.697+ NIL
13.698+
13.699+ "
13.700+ (with-gensyms (block)
13.701+ `(block ,block
13.702+ (let* ,(loop :for (symbol value) :in bindings
13.703+ :collect `(,symbol (or ,value
13.704+ (return-from ,block nil))))
13.705+ ,@body))))
13.706+
13.707+(defmacro if-let (bindings &body body)
13.708+ "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.
13.709+
13.710+ `body` must be of the form `(...optional-declarations... then else)`.
13.711+
13.712+ This macro combines `if` and `let`. It takes a list of bindings and
13.713+ binds them like `let` before executing the `then` branch of `body`, but
13.714+ if any binding's value evaluates to `nil` the process stops there and the
13.715+ `else` branch is immediately executed (with no bindings in effect).
13.716+
13.717+ If any `optional-declarations` are included they will only be in effect
13.718+ for the `then` branch.
13.719+
13.720+ Examples:
13.721+
13.722+ (if-let ((a (progn (print :a) 1))
13.723+ (b (progn (print :b) 2)))
13.724+ (list a b)
13.725+ 'nope)
13.726+ ; =>
13.727+ :A
13.728+ :B
13.729+ (1 2)
13.730+
13.731+ (if-let ((a (progn (print :a) nil))
13.732+ (b (progn (print :b) 2)))
13.733+ (list a b)
13.734+ 'nope)
13.735+ ; =>
13.736+ :A
13.737+ NOPE
13.738+
13.739+ "
13.740+ (with-gensyms (outer inner)
13.741+ (multiple-value-bind (body declarations) (parse-body body)
13.742+ (destructuring-bind (then else) body
13.743+ `(block ,outer
13.744+ (block ,inner
13.745+ (let ,(loop :for (symbol value) :in bindings
13.746+ :collect `(,symbol (or ,value
13.747+ (return-from ,inner nil))))
13.748+ ,@declarations
13.749+ (return-from ,outer ,then)))
13.750+ ,else)))))
13.751+
13.752+(defmacro if-let* (bindings then else)
13.753+ "Bind `bindings` serially and execute `then` if all are true, or `else` otherwise.
13.754+
13.755+ This macro combines `if` and `let*`. It takes a list of bindings and
13.756+ binds them like `let*` before executing `then`, but if any binding's
13.757+ value evaluates to `nil` the process stops and the `else` branch is
13.758+ immediately executed (with no bindings in effect).
13.759+
13.760+ Examples:
13.761+
13.762+ (if-let* ((a (progn (print :a) 1))
13.763+ (b (progn (print :b) (1+ a)))
13.764+ (list a b)
13.765+ 'nope)
13.766+ ; =>
13.767+ :A
13.768+ :B
13.769+ (1 2)
13.770+
13.771+ (if-let* ((a (progn (print :a) nil))
13.772+ (b (progn (print :b) (1+ a))))
13.773+ (list a b)
13.774+ 'nope)
13.775+ ; =>
13.776+ :A
13.777+ NOPE
13.778+
13.779+ "
13.780+ (with-gensyms (outer inner)
13.781+ `(block ,outer
13.782+ (block ,inner
13.783+ (let* ,(loop :for (symbol value) :in bindings
13.784+ :collect `(,symbol (or ,value
13.785+ (return-from ,inner nil))))
13.786+ (return-from ,outer ,then)))
13.787+ ,else)))
13.788+
13.789+
13.790+(defmacro def! (name &body body)
13.791+ "`defun' without args."
13.792+ `(defun ,name () ,@body))
13.793+
13.794+(defmacro eval-always (&body body)
13.795+ `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body))
13.796+
13.797+;;; TODO 2023-09-04: Env
13.798+
13.799+;;; Introspection
13.800+;; (eval-always (require :sb-introspect))
13.801+
13.802+;; (reexport-from :sb-introspect
13.803+;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit
13.804+;; :method-combination-lambda-list :deftype-lambda-list
13.805+;; :primitive-object-size :allocation-information
13.806+;; :function-type
13.807+;; :who-specializes-directly :who-specializes-generally
13.808+;; :find-function-callees :find-function-callers))
13.809+
13.810+;; ;;; Compiler
13.811+
13.812+;; (reexport-from :sb-c
13.813+;; :include '(:define-source-transformation
13.814+;; :parse-eval-when-situations
13.815+;; :source-location))
13.816+;;; Definitions
13.817+(defun %reevaluate-constant (name value test)
13.818+ (if (not (boundp name))
13.819+ value
13.820+ (let ((old (symbol-value name))
13.821+ (new value))
13.822+ (if (not (constantp name))
13.823+ (prog1 new
13.824+ (cerror "Try to redefine the variable as a constant."
13.825+ "~@<~S is an already bound non-constant variable ~
13.826+ whose value is ~S.~:@>" name old))
13.827+ (if (funcall test old new)
13.828+ old
13.829+ (restart-case
13.830+ (error "~@<~S is an already defined constant whose value ~
13.831+ ~S is not equal to the provided initial value ~S ~
13.832+ under ~S.~:@>" name old new test)
13.833+ (ignore ()
13.834+ :report "Retain the current value."
13.835+ old)
13.836+ (continue ()
13.837+ :report "Try to redefine the constant."
13.838+ new)))))))
13.839+
13.840+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
13.841+ "Ensures that the global variable named by NAME is a constant with a value
13.842+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
13.843+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
13.844+becomes the documentation string of the constant.
13.845+
13.846+Signals an error if NAME is already a bound non-constant variable.
13.847+
13.848+Signals an error if NAME is already a constant variable whose value is not
13.849+equal under TEST to result of evaluating INITIAL-VALUE."
13.850+ `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
13.851+ ,@(when documentation `(,documentation))))
13.852+
13.853+;;; Named Lambdas
13.854+;; (reexport-from :sb-int :include '(:make-macro-lambda :parse-lambda-list))
13.855+
13.856+;;; Sexp utils
13.857+;; (reexport-from :uiop :include '(read-file-form read-file-forms slurp-stream-forms))
13.858+
13.859+;;; cl-bench utils
13.860+;; Destructive merge of two sorted lists.
13.861+;; From Hansen's MS thesis.
13.862+(defun merge! (a b predicate)
13.863+ (labels ((merge-loop (r a b)
13.864+ (cond ((funcall predicate (car b) (car a))
13.865+ (setf (cdr r) b)
13.866+ (if (null (cdr b))
13.867+ (setf (cdr b) a)
13.868+ (merge-loop b a (cdr b))))
13.869+ (t ; (car a) <= (car b)
13.870+ (setf (cdr r) a)
13.871+ (if (null (cdr a))
13.872+ (setf (cdr a) b)
13.873+ (merge-loop a (cdr a) b))))))
13.874+ (cond ((null a) b)
13.875+ ((null b) a)
13.876+ ((funcall predicate (car b) (car a))
13.877+ (if (null (cdr b))
13.878+ (setf (cdr b) a)
13.879+ (merge-loop b a (cdr b)))
13.880+ b)
13.881+ (t ; (car a) <= (car b)
13.882+ (if (null (cdr a))
13.883+ (setf (cdr a) b)
13.884+ (merge-loop a (cdr a) b))
13.885+ a))))
13.886+
13.887+;; Stable sort procedure which copies the input list and then sorts
13.888+;; the new list imperatively. On the systems we have benchmarked,
13.889+;; this generic list sort has been at least as fast and usually much
13.890+;; faster than the library's sort routine.
13.891+;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren.
13.892+(defun sort! (seq predicate)
13.893+ (labels ((astep (n)
13.894+ (cond ((> n 2)
13.895+ (let* ((j (truncate n 2))
13.896+ (a (astep j))
13.897+ (k (- n j))
13.898+ (b (astep k)))
13.899+ (merge! a b predicate)))
13.900+ ((= n 2)
13.901+ (let ((x (car seq))
13.902+ (y (cadr seq))
13.903+ (p seq))
13.904+ (setf seq (cddr seq))
13.905+ (when (funcall predicate y x)
13.906+ (setf (car p) y)
13.907+ (setf (cadr p) x))
13.908+ (setf (cddr p) nil)
13.909+ p))
13.910+ ((= n 1)
13.911+ (let ((p seq))
13.912+ (setf seq (cdr seq))
13.913+ (setf (cdr p) nil)
13.914+ p))
13.915+ (t nil))))
13.916+ (astep (length seq))))
13.917+
13.918+;;; CLOS/MOP
13.919+(defun list-indirect-class-methods (class)
13.920+ "List all indirect methods of CLASS."
13.921+ (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class))))
13.922+
13.923+(defun list-class-methods (class methods &optional indirect)
13.924+ "List all methods specializing on CLASS modulo METHODS. When INDIRECT is
13.925+non-nil, also include indirect (parent) methods."
13.926+ (if (eq methods t)
13.927+ (if indirect
13.928+ (list-indirect-class-methods class)
13.929+ (specializer-direct-generic-functions class))
13.930+ (mapcar
13.931+ (lambda (s)
13.932+ (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name)))
13.933+ methods)))
13.934+
13.935+;; FIX 2023-09-13: need exclude param
13.936+(defun list-class-slots (class slots &optional exclude)
13.937+ ;; should probably convert slot-definition-name here
13.938+ (let ((cs (remove-if
13.939+ (lambda (s)
13.940+ (or
13.941+ (null s)
13.942+ (member t (mapcar
13.943+ (lambda (x)
13.944+ (string= (slot-definition-name s) x))
13.945+ exclude))))
13.946+ (class-slots class))))
13.947+ (if (eq slots t)
13.948+ cs
13.949+ (loop for s in slots
13.950+ with sn = (symb s)
13.951+ for c in cs
13.952+ with cn = (symb (slot-definition-name c))
13.953+ when (eq sn cn)
13.954+ collect c))))
13.955+
13.956+;; TODO 2023-09-09: slot exclusion from dynamic var
13.957+(defun list-slot-values-using-class (class obj slots &optional nullp unboundp)
13.958+ (remove-if
13.959+ #'null
13.960+ (mapcar
13.961+ (lambda (s)
13.962+ (let ((n (slot-definition-name s)))
13.963+ (let ((ns (make-keyword (symbol-name n))))
13.964+ (if (slot-boundp-using-class class obj s)
13.965+ (let ((v (slot-value-using-class class obj s)))
13.966+ (if nullp
13.967+ `(,ns ,v)
13.968+ (unless (null v)
13.969+ `(,ns ,v))))
13.970+ (when unboundp (list ns))))))
13.971+ slots)))
14.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2+++ b/lisp/std/list.lisp Mon Oct 16 19:33:42 2023 -0400
14.3@@ -0,0 +1,40 @@
14.4+;;; std/list.lisp --- List utils
14.5+
14.6+;;; Code:
14.7+(defpackage :std/list
14.8+ (:nicknames :list)
14.9+ (:use :cl)
14.10+ (:export
14.11+ #:ensure-car
14.12+ #:ensure-cons
14.13+ :let-binding-transform))
14.14+
14.15+(in-package :list)
14.16+
14.17+;; (reexport-from :sb-int
14.18+;; :include '(:recons :memq :assq :ensure-list :proper-list-of-length-p :proper-list-p
14.19+;; :singleton-p))
14.20+
14.21+(defun ensure-car (thing)
14.22+ "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
14.23+ (if (consp thing)
14.24+ (car thing)
14.25+ thing))
14.26+
14.27+(defun ensure-cons (cons)
14.28+ "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
14.29+ in the car, and NIL in the cdr."
14.30+ (if (consp cons)
14.31+ cons
14.32+ (cons cons nil)))
14.33+
14.34+(defun let-binding-transform (bs)
14.35+ (if bs
14.36+ (cons
14.37+ (cond ((symbolp (car bs))
14.38+ (list (car bs)))
14.39+ ((consp (car bs))
14.40+ (car bs))
14.41+ (t
14.42+ (error "Bad let bindings")))
14.43+ (let-binding-transform (cdr bs)))))
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/std/log.lisp Mon Oct 16 19:33:42 2023 -0400
15.3@@ -0,0 +1,90 @@
15.4+;;; log.lisp --- logging facade for lisp
15.5+
15.6+;; this package contains a simple logging facade for lisp applications
15.7+;; and libraries.
15.8+
15.9+;;; Commentary:
15.10+
15.11+;; Use `*log-level*' to set the current level of logging. Value is
15.12+;; either a bool or one of the following keywords: :warn :debug :info
15.13+;; :trace.
15.14+
15.15+;; top-level macros: info! trace! warn! debug!
15.16+
15.17+;; inspired by rust-lang/log https://crates.io/crates/log
15.18+
15.19+;; I intend to keep things simple for a while and then work out a DSL
15.20+;; for configuring logging. The DSL will be embedded in skelfiles.
15.21+
15.22+;;; Code:
15.23+(defpackage :std/log
15.24+ (:nicknames :log)
15.25+ (:use :cl :str :fmt :sym :fu)
15.26+ (:export :*log-level* :log-level-designator :log-timestamp-source
15.27+ :log! :warn! :info! :debug! :trace! :dbg!
15.28+ :debug-p))
15.29+
15.30+(in-package :log)
15.31+
15.32+(deftype log-level-designator () '(member :warn :debug :info :trace))
15.33+(declaim (type (or boolean log-level-designator) *log-level*))
15.34+(defparameter *log-level* nil)
15.35+(defparameter *logger* nil)
15.36+(defparameter *log-router* nil)
15.37+(declaim (type (or boolean function) *log-timestamp*))
15.38+(defparameter *log-timestamp* t
15.39+ "If non-nil, print a timestamp with log output. The value may be a
15.40+function in which case it is used as the function value of
15.41+`log-timestamp-source'.")
15.42+
15.43+;; TODO 2023-09-20: (declaim (inline log-timestamp-source)) ;; this
15.44+;; probably shouldn't be inlined.. bench it
15.45+(defun log-timestamp-source ()
15.46+ (if (functionp *log-timestamp*)
15.47+ (funcall *log-timestamp*)
15.48+ (format nil "~f" (/ (get-internal-real-time) internal-time-units-per-second))))
15.49+
15.50+;; the purpose of this struct is to route log messages to the
15.51+;; appropriate output stream. It should be configured and bound to
15.52+;; *LOG-ROUTER*.
15.53+(defstruct log-router
15.54+ info error debug trace)
15.55+
15.56+;; TODO 2023-09-20: make-synonym-stream, make-synonym-stream-symbol
15.57+(defvar *default-log-router*
15.58+ (make-log-router :info *terminal-io*
15.59+ :error *error-output*
15.60+ :debug *debug-io*
15.61+ :trace *trace-output*))
15.62+
15.63+(defstruct logger
15.64+ (active nil :type boolean)
15.65+ (timestamp *log-timestamp* :type (or boolean function))
15.66+ (router *default-log-router* :type log-router))
15.67+
15.68+(defmacro info! (opts &rest args))
15.69+
15.70+(defmacro trace! (opts &rest args))
15.71+
15.72+(defmacro warn! (opts &rest args))
15.73+
15.74+(defun debug-p () (eq *log-level* :debug))
15.75+
15.76+(defun debug-log-line ()
15.77+ (format t ":DEBUG~A~%"
15.78+ (if *log-timestamp*
15.79+ (format nil " @ ~A ~t" (log-timestamp-source))
15.80+ "")))
15.81+
15.82+;; TODO 2023-08-31: single format control string
15.83+(defun debug! (&rest args)
15.84+ (when (debug-p)
15.85+ (debug-log-line)
15.86+ ;; RESEARCH 2023-08-31: what's better here.. loop, do, mapc+nil?
15.87+ (map nil (lambda (x) (format t "; ~X~%" x)) args))
15.88+ args)
15.89+
15.90+(defun dbg! (&rest args)
15.91+ (when (debug-p)
15.92+ (debug-log-line)
15.93+ (apply #'describe args)))
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/lisp/std/named-readtables.lisp Mon Oct 16 19:33:42 2023 -0400
16.3@@ -0,0 +1,1111 @@
16.4+;;; named-readtables.lisp --- named-readtables
16.5+
16.6+;; The standard readtable is controlled by the Lisp implementation and
16.7+;; generally shouldn't be touched. There can be problems with
16.8+;; 'stacking' multiple read-macros as can be seen in this SO post:
16.9+;; https://stackoverflow.com/questions/73346051/how-can-i-modify-the-and-readtable-macros-in-lisp
16.10+
16.11+;; Instead, if you really want to change standard readtable behavior,
16.12+;; it is better to define your own readtables and be aware of the
16.13+;; context in which they are enabled. For example, loading a system
16.14+;; definition before enabling the readtable may cause divergent
16.15+;; behavior (using standard) versus your source code (custom).
16.16+
16.17+;;; Code:
16.18+(pkg:defpkg :std/named-readtables
16.19+ (:nicknames :named-readtables)
16.20+ (:use :cl)
16.21+ (:export
16.22+ #:defreadtable
16.23+ #:in-readtable
16.24+ #:make-readtable
16.25+ #:merge-readtables-into
16.26+ #:find-readtable
16.27+ #:ensure-readtable
16.28+ #:rename-readtable
16.29+ #:readtable-name
16.30+ #:register-readtable
16.31+ #:unregister-readtable
16.32+ #:copy-named-readtable
16.33+ #:list-all-named-readtables
16.34+ ;; Types
16.35+ #:named-readtable-designator
16.36+ ;; Conditions
16.37+ #:readtable-error
16.38+ #:reader-macro-conflict
16.39+ #:readtable-does-already-exist
16.40+ #:readtable-does-not-exist
16.41+ #:parse-body))
16.42+
16.43+(in-package :named-readtables)
16.44+(pushnew :named-readtables *features*)
16.45+
16.46+(defmacro without-package-lock ((&rest package-names) &body body)
16.47+ `(sb-ext:with-unlocked-packages (,@package-names) ,@body))
16.48+
16.49+;;; Taken from SWANK (which is Public Domain.)
16.50+
16.51+(defmacro destructure-case (value &body patterns)
16.52+ "Dispatch VALUE to one of PATTERNS.
16.53+A cross between `case' and `destructuring-bind'.
16.54+The pattern syntax is:
16.55+ ((HEAD . ARGS) . BODY)
16.56+The list of patterns is searched for a HEAD `eq' to the car of
16.57+VALUE. If one is found, the BODY is executed with ARGS bound to the
16.58+corresponding values in the CDR of VALUE."
16.59+ (let ((operator (gensym "op-"))
16.60+ (operands (gensym "rand-"))
16.61+ (tmp (gensym "tmp-")))
16.62+ `(let* ((,tmp ,value)
16.63+ (,operator (car ,tmp))
16.64+ (,operands (cdr ,tmp)))
16.65+ (case ,operator
16.66+ ,@(loop for (pattern . body) in patterns collect
16.67+ (if (eq pattern t)
16.68+ `(t ,@body)
16.69+ (destructuring-bind (op &rest rands) pattern
16.70+ `(,op (destructuring-bind ,rands ,operands
16.71+ ,@body)))))
16.72+ ,@(if (eq (caar (last patterns)) t)
16.73+ '()
16.74+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
16.75+
16.76+;;; Taken from Alexandria (which is Public Domain, or BSD.)
16.77+
16.78+(define-condition simple-style-warning (simple-warning style-warning)
16.79+ ())
16.80+
16.81+(defun simple-style-warn (format-control &rest format-args)
16.82+ (warn 'simple-style-warning
16.83+ :format-control format-control
16.84+ :format-arguments format-args))
16.85+
16.86+(define-condition simple-program-error (simple-error program-error)
16.87+ ())
16.88+
16.89+(defun simple-program-error (message &rest args)
16.90+ (error 'simple-program-error
16.91+ :format-control message
16.92+ :format-arguments args))
16.93+
16.94+(defun required-argument (&optional name)
16.95+ "Signals an error for a missing argument of NAME. Intended for
16.96+use as an initialization form for structure and class-slots, and
16.97+a default value for required keyword arguments."
16.98+ (error "Required argument ~@[~S ~]missing." name))
16.99+
16.100+(defun ensure-list (list)
16.101+ "If LIST is a list, it is returned. Otherwise returns the list
16.102+designated by LIST."
16.103+ (if (listp list)
16.104+ list
16.105+ (list list)))
16.106+
16.107+(declaim (inline ensure-function)) ; to propagate return type.
16.108+(declaim (ftype (function (t) (values function &optional))
16.109+ ensure-function))
16.110+(defun ensure-function (function-designator)
16.111+ "Returns the function designated by FUNCTION-DESIGNATOR:
16.112+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
16.113+it must be a function name and its FDEFINITION is returned."
16.114+ (if (functionp function-designator)
16.115+ function-designator
16.116+ (fdefinition function-designator)))
16.117+
16.118+(eval-when (:compile-toplevel :load-toplevel :execute)
16.119+(defun parse-body (body &key documentation whole)
16.120+ "Parses BODY into (values remaining-forms declarations doc-string).
16.121+Documentation strings are recognized only if DOCUMENTATION is true.
16.122+Syntax errors in body are signalled and WHOLE is used in the signal
16.123+arguments when given."
16.124+ (let ((doc nil)
16.125+ (decls nil)
16.126+ (current nil))
16.127+ (tagbody
16.128+ :declarations
16.129+ (setf current (car body))
16.130+ (when (and documentation (stringp current) (cdr body))
16.131+ (if doc
16.132+ (error "Too many documentation strings in ~S." (or whole body))
16.133+ (setf doc (pop body)))
16.134+ (go :declarations))
16.135+ (when (and (listp current) (eql (first current) 'declare))
16.136+ (push (pop body) decls)
16.137+ (go :declarations)))
16.138+ (values body (nreverse decls) doc)))
16.139+
16.140+(defun parse-ordinary-lambda-list (lambda-list)
16.141+ "Parses an ordinary lambda-list, returning as multiple values:
16.142+
16.143+ 1. Required parameters.
16.144+ 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
16.145+ where SUPPLIEDP is NIL if not present.
16.146+ 3. Name of the rest parameter, or NIL.
16.147+ 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
16.148+ where SUPPLIEDP is NIL if not present.
16.149+ 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
16.150+ 6. &AUX parameter specifications, normalized into form (NAME INIT).
16.151+
16.152+Signals a PROGRAM-ERROR is the lambda-list is malformed."
16.153+ (let ((state :required)
16.154+ (allow-other-keys nil)
16.155+ (auxp nil)
16.156+ (required nil)
16.157+ (optional nil)
16.158+ (rest nil)
16.159+ (keys nil)
16.160+ (aux nil))
16.161+ (labels ((simple-program-error (format-string &rest format-args)
16.162+ (error 'simple-program-error
16.163+ :format-control format-string
16.164+ :format-arguments format-args))
16.165+ (fail (elt)
16.166+ (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
16.167+ elt lambda-list))
16.168+ (check-variable (elt what)
16.169+ (unless (and (symbolp elt) (not (constantp elt)))
16.170+ (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
16.171+ what elt lambda-list)))
16.172+ (check-spec (spec what)
16.173+ (destructuring-bind (init suppliedp) spec
16.174+ (declare (ignore init))
16.175+ (check-variable suppliedp what)))
16.176+ (make-keyword (name)
16.177+ "Interns the string designated by NAME in the KEYWORD package."
16.178+ (intern (string name) :keyword)))
16.179+ (dolist (elt lambda-list)
16.180+ (case elt
16.181+ (&optional
16.182+ (if (eq state :required)
16.183+ (setf state elt)
16.184+ (fail elt)))
16.185+ (&rest
16.186+ (if (member state '(:required &optional))
16.187+ (setf state elt)
16.188+ (progn
16.189+ (break "state=~S" state)
16.190+ (fail elt))))
16.191+ (&key
16.192+ (if (member state '(:required &optional :after-rest))
16.193+ (setf state elt)
16.194+ (fail elt)))
16.195+ (&allow-other-keys
16.196+ (if (eq state '&key)
16.197+ (setf allow-other-keys t
16.198+ state elt)
16.199+ (fail elt)))
16.200+ (&aux
16.201+ (cond ((eq state '&rest)
16.202+ (fail elt))
16.203+ (auxp
16.204+ (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
16.205+ elt lambda-list))
16.206+ (t
16.207+ (setf auxp t
16.208+ state elt))
16.209+ ))
16.210+ (otherwise
16.211+ (when (member elt '#.(set-difference lambda-list-keywords
16.212+ '(&optional &rest &key &allow-other-keys &aux)))
16.213+ (simple-program-error
16.214+ "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
16.215+ elt lambda-list))
16.216+ (case state
16.217+ (:required
16.218+ (check-variable elt "required parameter")
16.219+ (push elt required))
16.220+ (&optional
16.221+ (cond ((consp elt)
16.222+ (destructuring-bind (name &rest tail) elt
16.223+ (check-variable name "optional parameter")
16.224+ (if (cdr tail)
16.225+ (check-spec tail "optional-supplied-p parameter")
16.226+ (setf elt (append elt '(nil))))))
16.227+ (t
16.228+ (check-variable elt "optional parameter")
16.229+ (setf elt (cons elt '(nil nil)))))
16.230+ (push elt optional))
16.231+ (&rest
16.232+ (check-variable elt "rest parameter")
16.233+ (setf rest elt
16.234+ state :after-rest))
16.235+ (&key
16.236+ (cond ((consp elt)
16.237+ (destructuring-bind (var-or-kv &rest tail) elt
16.238+ (cond ((consp var-or-kv)
16.239+ (destructuring-bind (keyword var) var-or-kv
16.240+ (unless (symbolp keyword)
16.241+ (simple-program-error "Invalid keyword name ~S in ordinary ~
16.242+ lambda-list:~% ~S"
16.243+ keyword lambda-list))
16.244+ (check-variable var "keyword parameter")))
16.245+ (t
16.246+ (check-variable var-or-kv "keyword parameter")
16.247+ (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
16.248+ (if (cdr tail)
16.249+ (check-spec tail "keyword-supplied-p parameter")
16.250+ (setf tail (append tail '(nil))))
16.251+ (setf elt (cons var-or-kv tail))))
16.252+ (t
16.253+ (check-variable elt "keyword parameter")
16.254+ (setf elt (list (list (make-keyword elt) elt) nil nil))))
16.255+ (push elt keys))
16.256+ (&aux
16.257+ (if (consp elt)
16.258+ (destructuring-bind (var &optional init) elt
16.259+ (declare (ignore init))
16.260+ (check-variable var "&aux parameter"))
16.261+ (check-variable elt "&aux parameter"))
16.262+ (push elt aux))
16.263+ (t
16.264+ (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
16.265+ (values (nreverse required) (nreverse optional) rest (nreverse keys)
16.266+ allow-other-keys (nreverse aux)))))
16.267+
16.268+(defmacro define-api (name lambda-list type-list &body body)
16.269+ (flet ((parse-type-list (type-list)
16.270+ (let ((pos (position '=> type-list)))
16.271+ (assert pos () "You forgot to specify return type (`=>' missing.)")
16.272+ (values (subseq type-list 0 pos)
16.273+ `(values ,@(nthcdr (1+ pos) type-list) &optional)))))
16.274+ (multiple-value-bind (body decls docstring)
16.275+ (parse-body body :documentation t :whole `(define-api ,name))
16.276+ (multiple-value-bind (arg-typespec value-typespec)
16.277+ (parse-type-list type-list)
16.278+ (multiple-value-bind (reqs opts rest keys)
16.279+ (parse-ordinary-lambda-list lambda-list)
16.280+ (declare (ignorable reqs opts rest keys))
16.281+ `(progn
16.282+ (declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
16.283+ (locally
16.284+ ;; Muffle the annoying "&OPTIONAL and &KEY found in
16.285+ ;; the same lambda list" style-warning
16.286+ #+sbcl (declare (sb-ext:muffle-conditions style-warning))
16.287+ (defun ,name ,lambda-list
16.288+ ,docstring
16.289+ ,@decls
16.290+ (locally
16.291+ #+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
16.292+ ;; SBCL will interpret the ftype declaration as
16.293+ ;; assertion and will insert type checks for us.
16.294+ ,@body)))))))))
16.295+
16.296+(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
16.297+ (assert (typep docstring 'string) (docstring) "Docstring missing!")
16.298+ (assert (not (null alternatives)))
16.299+ `(progn
16.300+ (declaim (inline ,name))
16.301+ (defun ,name ,lambda-list ,docstring ,(first alternatives))))
16.302+
16.303+(eval-when (:compile-toplevel :execute)
16.304+ #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
16.305+ (find-package "SB-IMPL"))
16.306+ (pushnew :sbcl+safe-standard-readtable *features*)))
16.307+
16.308+
16.309+
16.310+;;;; Mapping between a readtable object and its readtable-name.
16.311+
16.312+(defvar *readtable-names* (make-hash-table :test 'eq))
16.313+
16.314+(define-cruft %associate-readtable-with-name (name readtable)
16.315+ "Associate READTABLE with NAME for READTABLE-NAME to work."
16.316+ #+ :common-lisp (setf (gethash readtable *readtable-names*) name))
16.317+
16.318+(define-cruft %unassociate-readtable-from-name (name readtable)
16.319+ "Remove the association between READTABLE and NAME."
16.320+ #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
16.321+ (remhash readtable *readtable-names*)))
16.322+
16.323+(define-cruft %readtable-name (readtable)
16.324+ "Return the name associated with READTABLE."
16.325+ #+ :common-lisp (values (gethash readtable *readtable-names*)))
16.326+
16.327+(define-cruft %list-all-readtable-names ()
16.328+ "Return a list of all available readtable names."
16.329+ #+ :common-lisp (list* :standard :current :modern
16.330+ (loop for name being each hash-value of *readtable-names*
16.331+ collect name)))
16.332+
16.333+;;;; Mapping READTABLE objects to docstrings.
16.334+
16.335+(defvar *readtable-to-docstring* (make-hash-table :test 'eq))
16.336+
16.337+(defun %associate-docstring-with-readtable (readtable docstring)
16.338+ (setf (gethash readtable *readtable-to-docstring*) docstring))
16.339+
16.340+(defun %unassociate-docstring-from-readtable (readtable)
16.341+ (prog1 (gethash readtable *readtable-to-docstring*)
16.342+ (remhash readtable *readtable-to-docstring*)))
16.343+
16.344+;;;; Specialized DOCUMENTATION for named readtables.
16.345+
16.346+;;; Lispworks, at least, forbids defining methods on DOCUMENTATION.
16.347+;;; Wrapping these forms with WITHOUT-PACKAGE-LOCK (as for PRINT-OBJECT,
16.348+;;; see below) allows this to compile on Lispworks.
16.349+
16.350+(without-package-lock (:common-lisp #+lispworks :implementation)
16.351+
16.352+ (defmethod documentation ((name symbol) (doc-type (eql 'readtable)))
16.353+ (let ((readtable (find-readtable name)))
16.354+ (and readtable (gethash readtable *readtable-to-docstring*))))
16.355+
16.356+ (defmethod documentation ((readtable readtable) (doc-type (eql 'readtable)))
16.357+ (gethash readtable *readtable-to-docstring*))
16.358+
16.359+ (defmethod (setf documentation) (docstring (name symbol)
16.360+ (doc-type (eql 'readtable)))
16.361+ (let ((readtable (find-readtable name)))
16.362+ (unless readtable
16.363+ (error 'readtable-does-not-exist :readtable-name name))
16.364+ (setf (gethash readtable *readtable-to-docstring*) docstring)))
16.365+
16.366+ (defmethod (setf documentation) (docstring (readtable readtable)
16.367+ (doc-type (eql 'readtable)))
16.368+ (setf (gethash readtable *readtable-to-docstring*) docstring)))
16.369+
16.370+
16.371+;;;; Mapping between a readtable-name and the actual readtable object.
16.372+
16.373+;;; On Allegro we reuse their named-readtable support so we work
16.374+;;; nicely on their infrastructure.
16.375+
16.376+(defvar *named-readtables* (make-hash-table :test 'eq))
16.377+
16.378+(define-cruft %associate-name-with-readtable (name readtable)
16.379+ "Associate NAME with READTABLE for FIND-READTABLE to work."
16.380+ #+ :common-lisp (setf (gethash name *named-readtables*) readtable))
16.381+
16.382+(define-cruft %unassociate-name-from-readtable (name readtable)
16.383+ "Remove the association between NAME and READTABLE"
16.384+ #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
16.385+ (remhash name *named-readtables*)))
16.386+
16.387+(define-cruft %find-readtable (name)
16.388+ "Return the readtable named NAME."
16.389+ #+ :common-lisp (values (gethash name *named-readtables* nil)))
16.390+
16.391+
16.392+;;;; Reader-macro related predicates
16.393+
16.394+;;; CLISP creates new function objects for standard reader macros on
16.395+;;; each readtable copy.
16.396+(define-cruft function= (fn1 fn2)
16.397+ "Are reader-macro function-designators FN1 and FN2 the same?"
16.398+ (let ((fn1 (ensure-function fn1))
16.399+ (fn2 (ensure-function fn2)))
16.400+ (or (eq fn1 fn2)
16.401+ ;; After SBCL 1.1.18, for dispatch macro characters
16.402+ ;; GET-MACRO-CHARACTER returns closures whose name is:
16.403+ ;;
16.404+ ;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)
16.405+ ;;
16.406+ ;; Treat all these closures equivalent.
16.407+ (flet ((internal-dispatch-macro-closure-name-p (name)
16.408+ (find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name
16.409+ :key #'prin1-to-string :test #'string-equal)))
16.410+ (let ((n1 (sb-impl::%fun-name fn1))
16.411+ (n2 (sb-impl::%fun-name fn2)))
16.412+ (and (listp n1) (listp n2)
16.413+ (internal-dispatch-macro-closure-name-p n1)
16.414+ (internal-dispatch-macro-closure-name-p n2))))))
16.415+ #+ :common-lisp
16.416+ (eq (ensure-function fn1) (ensure-function fn2)))
16.417+
16.418+(define-cruft dispatch-macro-char-p (char rt)
16.419+ "Is CHAR a dispatch macro character in RT?"
16.420+ #+ :common-lisp
16.421+ (handler-case (locally
16.422+ (get-dispatch-macro-character char #\x rt)
16.423+ t)
16.424+ (error () nil)))
16.425+
16.426+;; (defun macro-char-p (char rt)
16.427+;; (let ((reader-fn (%get-macro-character char rt)))
16.428+;; (and reader-fn t)))
16.429+
16.430+;; (defun standard-macro-char-p (char rt)
16.431+;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
16.432+;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
16.433+;; (and (eq rt-fn std-fn)
16.434+;; (eq rt-flag std-flag)))))
16.435+
16.436+;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
16.437+;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
16.438+;; (and (eq (non-terminating-p disp-char rt)
16.439+;; (non-terminating-p disp-char *standard-readtable*))
16.440+;; (eq (get-dispatch-macro-character disp-char sub-char rt)
16.441+;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
16.442+
16.443+
16.444+;;;; Readtables Iterators
16.445+
16.446+(defmacro with-readtable-iterator ((name readtable) &body body)
16.447+ (let ((it (gensym)))
16.448+ `(let ((,it (%make-readtable-iterator ,readtable)))
16.449+ (macrolet ((,name () `(funcall ,',it)))
16.450+ ,@body))))
16.451+
16.452+(defun funcall-or (package-and-name-list &rest args)
16.453+ (loop for (package name) in package-and-name-list
16.454+ do (let ((symbol (find-symbol (string name) package)))
16.455+ (when symbol
16.456+ (return-from funcall-or (apply symbol args))))))
16.457+
16.458+(defun %make-readtable-iterator (readtable)
16.459+ (let ((char-macro-array (funcall-or '((sb-impl base-char-macro-array)
16.460+ (sb-impl character-macro-array))
16.461+ readtable))
16.462+ (char-macro-ht (funcall-or '((sb-impl extended-char-table)
16.463+ (sb-impl character-macro-hash-table))
16.464+ readtable))
16.465+ (dispatch-tables (sb-impl::dispatch-tables readtable))
16.466+ (char-code 0))
16.467+ (with-hash-table-iterator (ht-iterator char-macro-ht)
16.468+ (labels ((grovel-base-chars ()
16.469+ (if (>= char-code sb-int:base-char-code-limit)
16.470+ (grovel-unicode-chars)
16.471+ (let ((reader-fn (svref char-macro-array char-code))
16.472+ (char (code-char (shiftf char-code (1+ char-code)))))
16.473+ (if reader-fn
16.474+ (yield char)
16.475+ (grovel-base-chars)))))
16.476+ (grovel-unicode-chars ()
16.477+ (multiple-value-bind (more? char) (ht-iterator)
16.478+ (if (not more?)
16.479+ (values nil nil nil nil nil)
16.480+ (yield char))))
16.481+ (yield (char)
16.482+ (let ((disp-fn (get-macro-character char readtable))
16.483+ (disp-ht))
16.484+ (cond
16.485+ ((setq disp-ht (cdr (assoc char dispatch-tables)))
16.486+ (let ((sub-char-alist))
16.487+ (maphash (lambda (k v)
16.488+ (push (cons k v) sub-char-alist))
16.489+ disp-ht)
16.490+ (values t char disp-fn t sub-char-alist)))
16.491+ (t
16.492+ (values t char disp-fn nil nil))))))
16.493+ #'grovel-base-chars))))
16.494+
16.495+(defmacro do-readtable ((entry-designator readtable &optional result)
16.496+ &body body)
16.497+ "Iterate through a readtable's macro characters, and dispatch macro characters."
16.498+ (destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
16.499+ (if (symbolp entry-designator)
16.500+ (list entry-designator)
16.501+ entry-designator)
16.502+ (let ((iter (gensym "ITER+"))
16.503+ (more? (gensym "MORE?+"))
16.504+ (rt (gensym "READTABLE+")))
16.505+ `(let ((,rt ,readtable))
16.506+ (with-readtable-iterator (,iter ,rt)
16.507+ (loop
16.508+ (multiple-value-bind (,more?
16.509+ ,char
16.510+ ,@(when reader-fn (list reader-fn))
16.511+ ,@(when disp? (list disp?))
16.512+ ,@(when table (list table)))
16.513+ (,iter)
16.514+ (unless ,more? (return ,result))
16.515+ (let ,(when non-terminating-p
16.516+ ;; FIXME: N-T-P should be incorporated in iterators.
16.517+ `((,non-terminating-p
16.518+ (nth-value 1 (get-macro-character ,char ,rt)))))
16.519+ ,@body))))))))
16.520+
16.521+;;;; Misc
16.522+
16.523+;;; This should return an implementation's actual standard readtable
16.524+;;; object only if the implementation makes the effort to guard against
16.525+;;; modification of that object. Otherwise it should better return a
16.526+;;; copy.
16.527+(define-cruft %standard-readtable ()
16.528+ "Return the standard readtable."
16.529+ #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
16.530+ #+ :common-lisp (copy-readtable nil))
16.531+
16.532+;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
16.533+;;; readtable's dispatch table properly.
16.534+;;; Same goes for Allegro but that does not seem to provide a
16.535+;;; setter for their readtable's dispatch tables. Hence this ugly
16.536+;;; workaround.
16.537+(define-cruft %clear-readtable (readtable)
16.538+ "Make all macro characters in READTABLE be constituents."
16.539+ (prog1 readtable
16.540+ (do-readtable (char readtable)
16.541+ (set-syntax-from-char char #\A readtable))
16.542+ (setf (sb-impl::dispatch-tables readtable) nil))
16.543+ #+ :common-lisp
16.544+ (do-readtable (char readtable readtable)
16.545+ (set-syntax-from-char char #\A readtable)))
16.546+
16.547+(define-cruft %get-dispatch-macro-character (char subchar rt)
16.548+ "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
16.549+ #+ :common-lisp (get-dispatch-macro-character char subchar rt))
16.550+
16.551+(define-cruft %get-macro-character (char rt)
16.552+ "Ensure ANSI behaviour for GET-MACRO-CHARACTER."
16.553+ #+ :common-lisp (get-macro-character char rt))
16.554+
16.555+
16.556+;;;; Specialized PRINT-OBJECT for named readtables.
16.557+
16.558+;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
16.559+;;; that specializes on READTABLE is actually forbidden. It's quite
16.560+;;; likely to work (modulo package-locks) on most implementations,
16.561+;;; though.
16.562+
16.563+(without-package-lock (:common-lisp)
16.564+ (defmethod print-object :around ((rt readtable) stream)
16.565+ (let ((name (readtable-name rt)))
16.566+ (if name
16.567+ (print-unreadable-object (rt stream :type nil :identity t)
16.568+ (format stream "~A ~S" :named-readtable name))
16.569+ (call-next-method)))))
16.570+
16.571+;;;
16.572+;;; ``This is enough of a foothold to implement a more elaborate
16.573+;;; facility for using readtables in a localized way.''
16.574+;;;
16.575+;;; (X3J13 Cleanup Issue IN-SYNTAX)
16.576+;;;
16.577+
16.578+;;;;;; DEFREADTABLE &c.
16.579+(defmacro defreadtable (name &body options)
16.580+ "Define a new named readtable, whose name is given by the symbol NAME.
16.581+ Or, if a readtable is already registered under that name, redefine
16.582+ that one.
16.583+
16.584+ The readtable can be populated using the following OPTIONS:
16.585+
16.586+ - If the first element of OPTIONS is a string then it is associated
16.587+ with the readtable as in `(SETF (DOCUMENTATION NAME 'READTABLE)
16.588+ DOCSTRING)`.
16.589+
16.590+ - `(:MERGE READTABLE-DESIGNATORS+)`
16.591+
16.592+ Merge the macro character definitions from the readtables
16.593+ designated into the new readtable being defined as per
16.594+ MERGE-READTABLES-INTO. The copied options are
16.595+ :DISPATCH-MACRO-CHAR, :MACRO-CHAR and :SYNTAX-FROM, but not
16.596+ READTABLE-CASE.
16.597+
16.598+ If no :MERGE clause is given, an empty readtable is used. See
16.599+ MAKE-READTABLE.
16.600+
16.601+ - `(:FUSE READTABLE-DESIGNATORS+)`
16.602+
16.603+ Like :MERGE except:
16.604+
16.605+ Error conditions of type READER-MACRO-CONFLICT that are signaled
16.606+ during the merge operation will be silently _continued_. It
16.607+ follows that reader macros in earlier entries will be
16.608+ overwritten by later ones. For backward compatibility, :FUZE is
16.609+ accepted as an alias of :FUSE.
16.610+
16.611+ - `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)`
16.612+
16.613+ Define a new sub character `SUB-CHAR` for the dispatching macro
16.614+ character `MACRO-CHAR`, per SET-DISPATCH-MACRO-CHARACTER. You
16.615+ probably have to define `MACRO-CHAR` as a dispatching macro
16.616+ character by the following option first.
16.617+
16.618+ - `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])`
16.619+
16.620+ Define a new macro character in the readtable, per
16.621+ SET-MACRO-CHARACTER. If [FUNCTION][argument] is the keyword
16.622+ :DISPATCH, `MACRO-CHAR` is made a dispatching macro character,
16.623+ per MAKE-DISPATCH-MACRO-CHARACTER.
16.624+
16.625+ - `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)`
16.626+
16.627+ Set the character syntax of TO-CHAR in the readtable being
16.628+ defined to the same syntax as FROM-CHAR as per
16.629+ SET-SYNTAX-FROM-CHAR.
16.630+
16.631+ - `(:CASE CASE-MODE)`
16.632+
16.633+ Defines the _case sensitivity mode_ of the resulting readtable.
16.634+
16.635+ Any number of option clauses may appear. The options are grouped by
16.636+ their type, but in each group the order the options appeared
16.637+ textually is preserved. The following groups exist and are executed
16.638+ in the following order: :MERGE and :FUSE (one group), :CASE,
16.639+ :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally
16.640+ :SYNTAX-FROM.
16.641+
16.642+ Notes:
16.643+
16.644+ The readtable is defined at load-time. If you want to have it
16.645+ available at compilation time -- say to use its reader-macros in the
16.646+ same file as its definition -- you have to wrap the DEFREADTABLE
16.647+ form in an explicit EVAL-WHEN.
16.648+
16.649+ On redefinition, the target readtable is made empty first before
16.650+ it's refilled according to the clauses.
16.651+
16.652+ NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
16.653+ preregistered readtable names."
16.654+ (check-type name symbol)
16.655+ (when (reserved-readtable-name-p name)
16.656+ (error "~A is the designator for a predefined readtable. ~
16.657+ Not acceptable as a user-specified readtable name." name))
16.658+ (flet ((process-option (option var)
16.659+ (destructure-case option
16.660+ ((:merge &rest readtable-designators)
16.661+ `(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
16.662+ readtable-designators)))
16.663+ ((:fuse &rest readtable-designators)
16.664+ `(handler-bind ((reader-macro-conflict #'continue))
16.665+ (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
16.666+ readtable-designators))))
16.667+ ;; alias for :FUSE
16.668+ ((:fuze &rest readtable-designators)
16.669+ `(handler-bind ((reader-macro-conflict #'continue))
16.670+ (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x)
16.671+ readtable-designators))))
16.672+ ((:dispatch-macro-char disp-char sub-char function)
16.673+ `(set-dispatch-macro-character ,disp-char ,sub-char
16.674+ ,function ,var))
16.675+ ((:macro-char char function &optional non-terminating-p)
16.676+ (if (eq function :dispatch)
16.677+ `(make-dispatch-macro-character ,char ,non-terminating-p ,var)
16.678+ `(set-macro-character ,char ,function
16.679+ ,non-terminating-p ,var)))
16.680+ ((:syntax-from from-rt-designator from-char to-char)
16.681+ `(set-syntax-from-char ,to-char ,from-char
16.682+ ,var (find-readtable ,from-rt-designator)))
16.683+ ((:case mode)
16.684+ `(setf (readtable-case ,var) ,mode))))
16.685+ (remove-clauses (clauses options)
16.686+ (setq clauses (if (listp clauses) clauses (list clauses)))
16.687+ (remove-if-not #'(lambda (x) (member x clauses))
16.688+ options :key #'first)))
16.689+ (let* ((docstring (when (stringp (first options))
16.690+ (pop options)))
16.691+ (merge-clauses (remove-clauses '(:merge :fuze :fuse) options))
16.692+ (case-clauses (remove-clauses :case options))
16.693+ (macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)
16.694+ options))
16.695+ (syntax-clauses (remove-clauses :syntax-from options))
16.696+ (other-clauses
16.697+ (set-difference options
16.698+ (append merge-clauses case-clauses
16.699+ macro-clauses syntax-clauses))))
16.700+ (cond
16.701+ ((not (null other-clauses))
16.702+ (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
16.703+ (t
16.704+ `(eval-when (:load-toplevel :execute)
16.705+ ;; The (FIND-READTABLE ...) is important for proper
16.706+ ;; redefinition semantics, as redefining has to modify the
16.707+ ;; already existing readtable object.
16.708+ (let ((readtable (find-readtable ',name)))
16.709+ (cond ((not readtable)
16.710+ (setq readtable (make-readtable ',name)))
16.711+ (t
16.712+ (setq readtable (%clear-readtable readtable))
16.713+ (simple-style-warn
16.714+ "Overwriting already existing readtable ~S."
16.715+ readtable)))
16.716+ (setf (documentation readtable 'readtable) ,docstring)
16.717+ ,@(loop for option in merge-clauses
16.718+ collect (process-option option 'readtable))
16.719+ ,@(loop for option in case-clauses
16.720+ collect (process-option option 'readtable))
16.721+ ,@(loop for option in macro-clauses
16.722+ collect (process-option option 'readtable))
16.723+ ,@(loop for option in syntax-clauses
16.724+ collect (process-option option 'readtable))
16.725+ readtable)))))))
16.726+
16.727+(defmacro in-readtable (name)
16.728+ "Set *READTABLE* to the readtable referred to by the symbol NAME.
16.729+ Return the readtable."
16.730+ (check-type name symbol)
16.731+ `(eval-when (:compile-toplevel :load-toplevel :execute)
16.732+ ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
16.733+ ;; (GET-MACRO-CHARACTER #\"))
16.734+ (setf *readtable* (ensure-readtable ',name))
16.735+ (when (find-package :swank)
16.736+ (%frob-swank-readtable-alist *package* *readtable*))
16.737+ *readtable*))
16.738+
16.739+;;; KLUDGE: [interim solution]
16.740+;;;
16.741+;;; We need support for this in Slime itself, because we want IN-READTABLE
16.742+;;; to work on a per-file basis, and not on a per-package basis.
16.743+;;;
16.744+(defun %frob-swank-readtable-alist (package readtable)
16.745+ (let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
16.746+ (find-package :swank))))
16.747+ (when (boundp readtable-alist)
16.748+ (let ((new-item (cons (package-name package) readtable)))
16.749+ (setf (symbol-value readtable-alist)
16.750+ (cons
16.751+ new-item
16.752+ (remove new-item (symbol-value readtable-alist)
16.753+ :test (lambda (entry1 entry2)
16.754+ (string= (car entry1) (car entry2))))))))))
16.755+
16.756+(deftype readtable-designator ()
16.757+ `(or null readtable))
16.758+
16.759+(deftype named-readtable-designator ()
16.760+ "Either a symbol or a readtable itself."
16.761+ `(or readtable-designator symbol))
16.762+
16.763+;;;;; Compiler macros
16.764+
16.765+;;; Since the :STANDARD readtable is interned, and we can't enforce
16.766+;;; its immutability, we signal a style-warning for suspicious uses
16.767+;;; that may result in strange behaviour:
16.768+
16.769+;;; Modifying the standard readtable would, obviously, lead to a
16.770+;;; propagation of this change to all places which use the :STANDARD
16.771+;;; readtable (and thus rendering this readtable to be non-standard,
16.772+;;; in fact.)
16.773+(eval-when (:compile-toplevel :load-toplevel :execute)
16.774+ (defun constant-standard-readtable-expression-p (thing)
16.775+ (or (null thing)
16.776+ (eq thing :standard)
16.777+ (and (consp thing)
16.778+ (find thing
16.779+ '((find-readtable nil)
16.780+ (find-readtable :standard)
16.781+ (ensure-readtable nil)
16.782+ (ensure-readtable :standard))
16.783+ :test #'equal))))
16.784+
16.785+ (defun signal-suspicious-registration-warning (name-expr readtable-expr)
16.786+ (when (constant-standard-readtable-expression-p readtable-expr)
16.787+ (simple-style-warn
16.788+ "Caution: ~<You're trying to register the :STANDARD readtable ~
16.789+ under a new name ~S. As modification of the :STANDARD readtable ~
16.790+ is not permitted, subsequent modification of ~S won't be ~
16.791+ permitted either. You probably want to wrap COPY-READTABLE ~
16.792+ around~@:>~% ~S"
16.793+ (list name-expr name-expr) readtable-expr))))
16.794+
16.795+(define-compiler-macro register-readtable (&whole form name readtable)
16.796+ (signal-suspicious-registration-warning name readtable)
16.797+ form)
16.798+
16.799+(define-compiler-macro ensure-readtable (&whole form name &optional
16.800+ (default nil default-p))
16.801+ (when default-p
16.802+ (signal-suspicious-registration-warning name default))
16.803+ form)
16.804+
16.805+(declaim (special *standard-readtable* *empty-readtable*))
16.806+
16.807+(define-api make-readtable
16.808+ (&optional (name nil name-supplied-p) &key merge)
16.809+ (&optional named-readtable-designator &key (:merge list) => readtable)
16.810+ "Creates and returns a new readtable under the specified
16.811+ NAME.
16.812+
16.813+ MERGE takes a list of NAMED-READTABLE-DESIGNATORs and specifies the
16.814+ readtables the new readtable is created from. (See the :MERGE clause
16.815+ of DEFREADTABLE for details.)
16.816+
16.817+ If MERGE is NIL, an empty readtable is used instead.
16.818+
16.819+ If NAME is not given, an anonymous empty readtable is returned.
16.820+
16.821+ Notes:
16.822+
16.823+ An empty readtable is a readtable where each character's syntax is
16.824+ the same as in the _standard readtable_ except that each macro
16.825+ character has been made a constituent. Basically: whitespace stays
16.826+ whitespace, everything else is constituent."
16.827+ (cond ((not name-supplied-p)
16.828+ (copy-readtable *empty-readtable*))
16.829+ ((reserved-readtable-name-p name)
16.830+ (error "~A is the designator for a predefined readtable. ~
16.831+ Not acceptable as a user-specified readtable name." name))
16.832+ ((let ((rt (find-readtable name)))
16.833+ (and rt (prog1 nil
16.834+ (cerror "Overwrite existing entry."
16.835+ 'readtable-does-already-exist :readtable-name name)
16.836+ ;; Explicitly unregister to make sure that we do
16.837+ ;; not hold on of any reference to RT.
16.838+ (unregister-readtable rt)))))
16.839+ (t (let ((result (apply #'merge-readtables-into
16.840+ ;; The first readtable specified in
16.841+ ;; the :merge list is taken as the
16.842+ ;; basis for all subsequent
16.843+ ;; (destructive!) modifications (and
16.844+ ;; hence it's copied.)
16.845+ (copy-readtable (if merge
16.846+ (ensure-readtable
16.847+ (first merge))
16.848+ *empty-readtable*))
16.849+ (rest merge))))
16.850+
16.851+ (register-readtable name result)))))
16.852+
16.853+(define-api rename-readtable
16.854+ (old-name new-name)
16.855+ (named-readtable-designator symbol => readtable)
16.856+ "Replaces the associated name of the readtable designated by
16.857+ OLD-NAME with NEW-NAME. If a readtable is already registered under
16.858+ NEW-NAME, an error of type READTABLE-DOES-ALREADY-EXIST is
16.859+ signaled."
16.860+ (when (find-readtable new-name)
16.861+ (cerror "Overwrite existing entry."
16.862+ 'readtable-does-already-exist :readtable-name new-name))
16.863+ (let* ((readtable (ensure-readtable old-name))
16.864+ (readtable-name (readtable-name readtable)))
16.865+ ;; We use the internal functions directly to omit repeated
16.866+ ;; type-checking.
16.867+ (%unassociate-name-from-readtable readtable-name readtable)
16.868+ (%unassociate-readtable-from-name readtable-name readtable)
16.869+ (%associate-name-with-readtable new-name readtable)
16.870+ (%associate-readtable-with-name new-name readtable)
16.871+ (%associate-docstring-with-readtable
16.872+ readtable (%unassociate-docstring-from-readtable readtable))
16.873+ readtable))
16.874+
16.875+(define-api merge-readtables-into
16.876+ (result-readtable &rest named-readtables)
16.877+ (named-readtable-designator &rest named-readtable-designator => readtable)
16.878+ "Copy macro character definitions of each readtable in
16.879+ NAMED-READTABLES into RESULT-READTABLE.
16.880+
16.881+ If a macro character appears in more than one of the readtables,
16.882+ i.e. if a conflict is discovered during the merge, an error of type
16.883+ READER-MACRO-CONFLICT is signaled.
16.884+
16.885+ The copied options are :DISPATCH-MACRO-CHAR, :MACRO-CHAR and
16.886+ :SYNTAX-FROM, but not READTABLE-CASE."
16.887+ (flet ((merge-into (to from)
16.888+ (do-readtable ((char reader-fn non-terminating-p disp? table) from)
16.889+ (check-reader-macro-conflict from to char)
16.890+ (cond ((not disp?)
16.891+ (set-macro-character char reader-fn non-terminating-p to))
16.892+ (t
16.893+ (ensure-dispatch-macro-character char non-terminating-p to)
16.894+ (loop for (subchar . subfn) in table do
16.895+ (check-reader-macro-conflict from to char subchar)
16.896+ (set-dispatch-macro-character char subchar
16.897+ subfn to)))))
16.898+ to))
16.899+ (let ((result-table (ensure-readtable result-readtable)))
16.900+ (dolist (table (mapcar #'ensure-readtable named-readtables))
16.901+ (merge-into result-table table))
16.902+ result-table)))
16.903+
16.904+(defun ensure-dispatch-macro-character (char &optional non-terminating-p
16.905+ (readtable *readtable*))
16.906+ (if (dispatch-macro-char-p char readtable)
16.907+ t
16.908+ (make-dispatch-macro-character char non-terminating-p readtable)))
16.909+
16.910+(define-api copy-named-readtable
16.911+ (named-readtable)
16.912+ (named-readtable-designator => readtable)
16.913+ "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
16.914+ (copy-readtable (ensure-readtable named-readtable)))
16.915+
16.916+(define-api list-all-named-readtables () (=> list)
16.917+ "Returns a list of all registered readtables. The returned list is
16.918+ guaranteed to be fresh, but may contain duplicates."
16.919+ (mapcar #'ensure-readtable (%list-all-readtable-names)))
16.920+
16.921+
16.922+(define-condition readtable-error (error) ())
16.923+
16.924+(define-condition readtable-does-not-exist (readtable-error)
16.925+ ((readtable-name :initarg :readtable-name
16.926+ :initform (required-argument)
16.927+ :accessor missing-readtable-name
16.928+ :type named-readtable-designator))
16.929+ (:report (lambda (condition stream)
16.930+ (format stream "A readtable named ~S does not exist."
16.931+ (missing-readtable-name condition)))))
16.932+
16.933+(define-condition readtable-does-already-exist (readtable-error)
16.934+ ((readtable-name :initarg :readtable-name
16.935+ :initform (required-argument)
16.936+ :accessor existing-readtable-name
16.937+ :type named-readtable-designator))
16.938+ (:report (lambda (condition stream)
16.939+ (format stream "A readtable named ~S already exists."
16.940+ (existing-readtable-name condition))))
16.941+ (:documentation "Continuable."))
16.942+
16.943+(define-condition reader-macro-conflict (readtable-error)
16.944+ ((macro-char
16.945+ :initarg :macro-char
16.946+ :initform (required-argument)
16.947+ :accessor conflicting-macro-char
16.948+ :type character)
16.949+ (sub-char
16.950+ :initarg :sub-char
16.951+ :initform nil
16.952+ :accessor conflicting-dispatch-sub-char
16.953+ :type (or null character))
16.954+ (from-readtable
16.955+ :initarg :from-readtable
16.956+ :initform (required-argument)
16.957+ :accessor from-readtable
16.958+ :type readtable)
16.959+ (to-readtable
16.960+ :initarg :to-readtable
16.961+ :initform (required-argument)
16.962+ :accessor to-readtable
16.963+ :type readtable))
16.964+ (:report
16.965+ (lambda (condition stream)
16.966+ (format stream "~@<Reader macro conflict while trying to merge the ~
16.967+ ~:[macro character~;dispatch macro characters~] ~
16.968+ ~@C~@[ ~@C~] from ~A into ~A.~@:>"
16.969+ (conflicting-dispatch-sub-char condition)
16.970+ (conflicting-macro-char condition)
16.971+ (conflicting-dispatch-sub-char condition)
16.972+ (from-readtable condition)
16.973+ (to-readtable condition))))
16.974+ (:documentation "Continuable.
16.975+
16.976+ This condition is signaled during the merge process if a reader
16.977+ macro (be it a macro character or the sub character of a dispatch
16.978+ macro character) is present in the both source and the target
16.979+ readtable and the two respective reader macro functions differ."))
16.980+
16.981+(defun check-reader-macro-conflict (from to char &optional subchar)
16.982+ (flet ((conflictp (from-fn to-fn)
16.983+ (assert from-fn ()
16.984+ "Bug in readtable iterators or concurrent access?")
16.985+ (and to-fn (not (function= to-fn from-fn)))))
16.986+ (when (if subchar
16.987+ (conflictp (%get-dispatch-macro-character char subchar from)
16.988+ (%get-dispatch-macro-character char subchar to))
16.989+ (conflictp (%get-macro-character char from)
16.990+ (%get-macro-character char to)))
16.991+ (cerror (format nil "Overwrite ~@C in ~A." char to)
16.992+ 'reader-macro-conflict
16.993+ :from-readtable from
16.994+ :to-readtable to
16.995+ :macro-char char
16.996+ :sub-char subchar))))
16.997+
16.998+
16.999+;;; Although there is no way to get at the standard readtable in
16.1000+;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
16.1001+;;; up the perception of its existence by interning a copy of it.
16.1002+;;;
16.1003+;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
16.1004+;;;
16.1005+;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")
16.1006+;;;
16.1007+;;; holding true.
16.1008+;;;
16.1009+;;; We, however, inherit the restriction that the :STANDARD
16.1010+;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
16.1011+;;; technically be feasible (as *STANDARD-READTABLE* will contain a
16.1012+;;; mutable copy of the implementation-internal standard readtable.)
16.1013+;;; We cannot enforce this restriction without shadowing
16.1014+;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
16.1015+;;; is out of scope of this library, though. So we just threaten
16.1016+;;; with nasal demons.
16.1017+;;;
16.1018+(defvar *standard-readtable*
16.1019+ (%standard-readtable))
16.1020+
16.1021+(defvar *empty-readtable*
16.1022+ (%clear-readtable (copy-readtable nil)))
16.1023+
16.1024+(defvar *case-preserving-standard-readtable*
16.1025+ (let ((readtable (copy-readtable nil)))
16.1026+ (setf (readtable-case readtable) :preserve)
16.1027+ readtable))
16.1028+
16.1029+(defparameter *reserved-readtable-names*
16.1030+ '(nil :standard :common-lisp :modern :current))
16.1031+
16.1032+(defun reserved-readtable-name-p (name)
16.1033+ (and (member name *reserved-readtable-names*) t))
16.1034+
16.1035+;;; In principle, we could DEFREADTABLE some of these. But we do
16.1036+;;; reserved readtable lookup seperately, since we can't register a
16.1037+;;; readtable for :CURRENT anyway.
16.1038+
16.1039+(defun find-reserved-readtable (reserved-name)
16.1040+ (cond ((eq reserved-name nil) *standard-readtable*)
16.1041+ ((eq reserved-name :standard) *standard-readtable*)
16.1042+ ((eq reserved-name :common-lisp) *standard-readtable*)
16.1043+ ((eq reserved-name :modern) *case-preserving-standard-readtable*)
16.1044+ ((eq reserved-name :current) *readtable*)
16.1045+ (t (error "Bug: no such reserved readtable: ~S" reserved-name))))
16.1046+
16.1047+(define-api find-readtable
16.1048+ (name)
16.1049+ (named-readtable-designator => (or readtable null))
16.1050+ "Looks for the readtable specified by NAME and returns it if it is
16.1051+ found. Returns NIL otherwise."
16.1052+ (cond ((readtablep name) name)
16.1053+ ((reserved-readtable-name-p name)
16.1054+ (find-reserved-readtable name))
16.1055+ ((%find-readtable name))))
16.1056+
16.1057+;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
16.1058+;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
16.1059+;;; macros below.)
16.1060+(defsetf find-readtable register-readtable)
16.1061+
16.1062+(define-api ensure-readtable
16.1063+ (name &optional (default nil default-p))
16.1064+ (named-readtable-designator &optional (or named-readtable-designator null)
16.1065+ => readtable)
16.1066+ "Looks up the readtable specified by NAME and returns it if it's found.
16.1067+ If it is not found, it registers the readtable designated by DEFAULT
16.1068+ under the name represented by NAME; or if no default argument is
16.1069+ given, it signals an error of type READTABLE-DOES-NOT-EXIST
16.1070+ instead."
16.1071+ (cond ((find-readtable name))
16.1072+ ((not default-p)
16.1073+ (error 'readtable-does-not-exist :readtable-name name))
16.1074+ (t (setf (find-readtable name) (ensure-readtable default)))))
16.1075+
16.1076+
16.1077+(define-api register-readtable
16.1078+ (name readtable)
16.1079+ (symbol readtable => readtable)
16.1080+ "Associate READTABLE with NAME. Returns the readtable."
16.1081+ (assert (typep name '(not (satisfies reserved-readtable-name-p))))
16.1082+ (%associate-readtable-with-name name readtable)
16.1083+ (%associate-name-with-readtable name readtable)
16.1084+ readtable)
16.1085+
16.1086+(define-api unregister-readtable
16.1087+ (named-readtable)
16.1088+ (named-readtable-designator => boolean)
16.1089+ "Remove the association of NAMED-READTABLE. Returns T if successfull,
16.1090+ NIL otherwise."
16.1091+ (let* ((readtable (find-readtable named-readtable))
16.1092+ (readtable-name (and readtable (readtable-name readtable))))
16.1093+ (if (not readtable-name)
16.1094+ nil
16.1095+ (prog1 t
16.1096+ (check-type readtable-name
16.1097+ (not (satisfies reserved-readtable-name-p)))
16.1098+ (%unassociate-readtable-from-name readtable-name readtable)
16.1099+ (%unassociate-name-from-readtable readtable-name readtable)
16.1100+ (%unassociate-docstring-from-readtable readtable)))))
16.1101+
16.1102+(define-api readtable-name
16.1103+ (named-readtable)
16.1104+ (named-readtable-designator => symbol)
16.1105+ "Returns the name of the readtable designated by NAMED-READTABLE,
16.1106+ or NIL."
16.1107+ (let ((readtable (ensure-readtable named-readtable)))
16.1108+ (cond ((%readtable-name readtable))
16.1109+ ((eq readtable *readtable*) :current)
16.1110+ ((eq readtable *standard-readtable*) :common-lisp)
16.1111+ ((eq readtable *case-preserving-standard-readtable*) :modern)
16.1112+ (t nil))))
16.1113+
16.1114+(provide :readtables)
17.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2+++ b/lisp/std/pan.lisp Mon Oct 16 19:33:42 2023 -0400
17.3@@ -0,0 +1,98 @@
17.4+;;; pan.lisp --- Pandoric macros
17.5+
17.6+;;; Code:
17.7+(defpackage :std/pan
17.8+ (:nicknames :pan)
17.9+ (:use :cl :named-readtables :fu :ana)
17.10+ (:export
17.11+ #:pandoriclet
17.12+ #:pandoriclet-get
17.13+ #:pandoriclet-set
17.14+ #:get-pandoric
17.15+ #:with-pandoric
17.16+ #:pandoric-hotpatch
17.17+ #:pandoric-recode
17.18+ #:plambda
17.19+ #:pandoric-eval))
17.20+
17.21+(in-package :pan)
17.22+(in-readtable :std)
17.23+
17.24+(defun pandoriclet-get (letargs)
17.25+ `(case sym
17.26+ ,@(mapcar #`((,(car a1)) ,(car a1))
17.27+ letargs)
17.28+ (t (error
17.29+ "Unknown pandoric get: ~a"
17.30+ sym))))
17.31+
17.32+(defun pandoriclet-set (letargs)
17.33+ `(case sym
17.34+ ,@(mapcar #`((,(car a1))
17.35+ (setq ,(car a1) val))
17.36+ letargs)
17.37+ (t (error
17.38+ "Unknown pandoric set: ~a"
17.39+ sym))))
17.40+
17.41+(defmacro pandoriclet (letargs &rest body)
17.42+ (let ((letargs (cons
17.43+ '(this)
17.44+ (let-binding-transform
17.45+ letargs))))
17.46+ `(let (,@letargs)
17.47+ (setq this ,@(last body))
17.48+ ,@(butlast body)
17.49+ (dlambda
17.50+ (:pandoric-get (sym)
17.51+ ,(pandoriclet-get letargs))
17.52+ (:pandoric-set (sym val)
17.53+ ,(pandoriclet-set letargs))
17.54+ (t (&rest args)
17.55+ (apply this args))))))
17.56+
17.57+(declaim (inline get-pandoric))
17.58+
17.59+(defun get-pandoric (box sym)
17.60+ (funcall box :pandoric-get sym))
17.61+
17.62+(defsetf get-pandoric (box sym) (val)
17.63+ `(progn
17.64+ (funcall ,box :pandoric-set ,sym ,val)
17.65+ ,val))
17.66+
17.67+(defmacro! with-pandoric (syms o!box &rest body)
17.68+ `(symbol-macrolet
17.69+ (,@(mapcar #`(,a1 (get-pandoric ,g!box ',a1))
17.70+ syms))
17.71+ ,@body))
17.72+
17.73+(defun pandoric-hotpatch (box new)
17.74+ (with-pandoric (this) box
17.75+ (setq this new)))
17.76+
17.77+(defmacro pandoric-recode (vars box new)
17.78+ `(with-pandoric (this ,@vars) ,box
17.79+ (setq this ,new)))
17.80+
17.81+(defmacro plambda (largs pargs &rest body)
17.82+ (let ((pargs (mapcar #'list pargs)))
17.83+ `(let (this self)
17.84+ (setq
17.85+ this (lambda ,largs ,@body)
17.86+ self (dlambda
17.87+ (:pandoric-get (sym)
17.88+ ,(pandoriclet-get pargs))
17.89+ (:pandoric-set (sym val)
17.90+ ,(pandoriclet-set pargs))
17.91+ (t (&rest args)
17.92+ (apply this args)))))))
17.93+
17.94+(defvar pandoric-eval-tunnel)
17.95+
17.96+(defmacro pandoric-eval (vars expr)
17.97+ `(let ((pandoric-eval-tunnel
17.98+ (plambda () ,vars t)))
17.99+ (eval `(with-pandoric
17.100+ ,',vars pandoric-eval-tunnel
17.101+ ,,expr))))
18.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2+++ b/lisp/std/pkg.lisp Mon Oct 16 19:33:42 2023 -0400
18.3@@ -0,0 +1,720 @@
18.4+;;; pkg.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*-
18.5+;;; Code:
18.6+(defpackage :std/pkg
18.7+ (:nicknames :pkg)
18.8+ (:use :cl)
18.9+ (:export :defpkg
18.10+ #:find-package* #:find-symbol* #:symbol-call
18.11+ #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
18.12+ #:symbol-shadowing-p #:home-package-p
18.13+ #:symbol-package-name #:standard-common-lisp-symbol-p
18.14+ #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
18.15+ #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
18.16+ #:ensure-package-unused #:delete-package*
18.17+ #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
18.18+ #:package-definition-form #:parse-defpkg-form
18.19+ #:ensure-package))
18.20+
18.21+(in-package :pkg)
18.22+
18.23+(eval-when (:load-toplevel :compile-toplevel :execute)
18.24+ (defun find-package* (package-designator &optional (error t))
18.25+ (let ((package (find-package package-designator)))
18.26+ (cond
18.27+ (package package)
18.28+ (error (error "No package named ~S" (string package-designator)))
18.29+ (t nil))))
18.30+ (defun find-symbol* (name package-designator &optional (error t))
18.31+ "Find a symbol in a package of given string'ified NAME;
18.32+unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
18.33+by letting you supply a symbol or keyword for the name;
18.34+also works well when the package is not present.
18.35+If optional ERROR argument is NIL, return NIL instead of an error
18.36+when the symbol is not found."
18.37+ (block nil
18.38+ (let ((package (find-package* package-designator error)))
18.39+ (when package ;; package error handled by find-package* already
18.40+ (multiple-value-bind (symbol status) (find-symbol (string name) package)
18.41+ (cond
18.42+ (status (return (values symbol status)))
18.43+ (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
18.44+ (values nil nil))))
18.45+ (defun symbol-call (package name &rest args)
18.46+ "Call a function associated with symbol of given name in given package,
18.47+with given ARGS. Useful when the call is read before the package is loaded,
18.48+or when loading the package is optional."
18.49+ (apply (find-symbol* name package) args))
18.50+ (defun intern* (name package-designator &optional (error t))
18.51+ (intern (string name) (find-package* package-designator error)))
18.52+ (defun export* (name package-designator)
18.53+ (let* ((package (find-package* package-designator))
18.54+ (symbol (intern* name package)))
18.55+ (export (or symbol (list symbol)) package)))
18.56+ (defun import* (symbol package-designator)
18.57+ (import (or symbol (list symbol)) (find-package* package-designator)))
18.58+ (defun shadowing-import* (symbol package-designator)
18.59+ (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
18.60+ (defun shadow* (name package-designator)
18.61+ (shadow (list (string name)) (find-package* package-designator)))
18.62+ (defun make-symbol* (name)
18.63+ (etypecase name
18.64+ (string (make-symbol name))
18.65+ (symbol (copy-symbol name))))
18.66+ (defun unintern* (name package-designator &optional (error t))
18.67+ (block nil
18.68+ (let ((package (find-package* package-designator error)))
18.69+ (when package
18.70+ (multiple-value-bind (symbol status) (find-symbol* name package error)
18.71+ (cond
18.72+ (status (unintern symbol package)
18.73+ (return (values symbol status)))
18.74+ (error (error "symbol ~A not present in package ~A"
18.75+ (string symbol) (package-name package))))))
18.76+ (values nil nil))))
18.77+ (defun symbol-shadowing-p (symbol package)
18.78+ (and (member symbol (package-shadowing-symbols package)) t))
18.79+ (defun home-package-p (symbol package)
18.80+ (and package (let ((sp (symbol-package symbol)))
18.81+ (and sp (let ((pp (find-package* package)))
18.82+ (and pp (eq sp pp))))))))
18.83+
18.84+
18.85+(eval-when (:load-toplevel :compile-toplevel :execute)
18.86+ (defun symbol-package-name (symbol)
18.87+ (let ((package (symbol-package symbol)))
18.88+ (and package (package-name package))))
18.89+ (defun standard-common-lisp-symbol-p (symbol)
18.90+ (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
18.91+ (and (eq sym symbol) (eq status :external))))
18.92+ (defun reify-package (package &optional package-context)
18.93+ (if (eq package package-context) t
18.94+ (etypecase package
18.95+ (null nil)
18.96+ ((eql (find-package :cl)) :cl)
18.97+ (package (package-name package)))))
18.98+ (defun unreify-package (package &optional package-context)
18.99+ (etypecase package
18.100+ (null nil)
18.101+ ((eql t) package-context)
18.102+ ((or symbol string) (find-package package))))
18.103+ (defun reify-symbol (symbol &optional package-context)
18.104+ (etypecase symbol
18.105+ ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
18.106+ (symbol (vector (symbol-name symbol)
18.107+ (reify-package (symbol-package symbol) package-context)))))
18.108+ (defun unreify-symbol (symbol &optional package-context)
18.109+ (etypecase symbol
18.110+ (symbol symbol)
18.111+ ((simple-vector 2)
18.112+ (let* ((symbol-name (svref symbol 0))
18.113+ (package-foo (svref symbol 1))
18.114+ (package (unreify-package package-foo package-context)))
18.115+ (if package (intern* symbol-name package)
18.116+ (make-symbol* symbol-name)))))))
18.117+
18.118+(eval-when (:load-toplevel :compile-toplevel :execute)
18.119+ (defvar *all-package-happiness* '())
18.120+ (defvar *all-package-fishiness* (list t))
18.121+ (defun record-fishy (info)
18.122+ ;;(format t "~&FISHY: ~S~%" info)
18.123+ (push info *all-package-fishiness*))
18.124+ (defmacro when-package-fishiness (&body body)
18.125+ `(when *all-package-fishiness* ,@body))
18.126+ (defmacro note-package-fishiness (&rest info)
18.127+ `(when-package-fishiness (record-fishy (list ,@info)))))
18.128+
18.129+(eval-when (:load-toplevel :compile-toplevel :execute)
18.130+ #+(or clisp clozure)
18.131+ (defun get-setf-function-symbol (symbol)
18.132+ #+clisp (let ((sym (get symbol 'system::setf-function)))
18.133+ (if sym (values sym :setf-function)
18.134+ (let ((sym (get symbol 'system::setf-expander)))
18.135+ (if sym (values sym :setf-expander)
18.136+ (values nil nil)))))
18.137+ #+clozure (gethash symbol ccl::%setf-function-names%))
18.138+ #+(or clisp clozure)
18.139+ (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
18.140+ #+clisp (assert (member kind '(:setf-function :setf-expander)))
18.141+ #+clozure (assert (eq kind t))
18.142+ #+clisp
18.143+ (cond
18.144+ ((null new-setf-symbol)
18.145+ (remprop symbol 'system::setf-function)
18.146+ (remprop symbol 'system::setf-expander))
18.147+ ((eq kind :setf-function)
18.148+ (setf (get symbol 'system::setf-function) new-setf-symbol))
18.149+ ((eq kind :setf-expander)
18.150+ (setf (get symbol 'system::setf-expander) new-setf-symbol))
18.151+ (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
18.152+ kind symbol new-setf-symbol)))
18.153+ #+clozure
18.154+ (progn
18.155+ (gethash symbol ccl::%setf-function-names%) new-setf-symbol
18.156+ (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
18.157+ #+(or clisp clozure)
18.158+ (defun create-setf-function-symbol (symbol)
18.159+ #+clisp (system::setf-symbol symbol)
18.160+ #+clozure (ccl::construct-setf-function-name symbol))
18.161+ (defun set-dummy-symbol (symbol reason other-symbol)
18.162+ (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
18.163+ (defun make-dummy-symbol (symbol)
18.164+ (let ((dummy (copy-symbol symbol)))
18.165+ (set-dummy-symbol dummy 'replacing symbol)
18.166+ (set-dummy-symbol symbol 'replaced-by dummy)
18.167+ dummy))
18.168+ (defun dummy-symbol (symbol)
18.169+ (get symbol 'dummy-symbol))
18.170+ (defun get-dummy-symbol (symbol)
18.171+ (let ((existing (dummy-symbol symbol)))
18.172+ (if existing (values (cdr existing) (car existing))
18.173+ (make-dummy-symbol symbol))))
18.174+ (defun nuke-symbol-in-package (symbol package-designator)
18.175+ (let ((package (find-package* package-designator))
18.176+ (name (symbol-name symbol)))
18.177+ (multiple-value-bind (sym stat) (find-symbol name package)
18.178+ (when (and (member stat '(:internal :external)) (eq symbol sym))
18.179+ (if (symbol-shadowing-p symbol package)
18.180+ (shadowing-import* (get-dummy-symbol symbol) package)
18.181+ (unintern* symbol package))))))
18.182+ (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
18.183+ #+(or clisp clozure)
18.184+ (multiple-value-bind (setf-symbol kind)
18.185+ (get-setf-function-symbol symbol)
18.186+ (when kind (nuke-symbol setf-symbol)))
18.187+ (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
18.188+ (defun rehome-symbol (symbol package-designator)
18.189+ "Changes the home package of a symbol, also leaving it present in its old home if any"
18.190+ (let* ((name (symbol-name symbol))
18.191+ (package (find-package* package-designator))
18.192+ (old-package (symbol-package symbol))
18.193+ (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
18.194+ (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
18.195+ (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
18.196+ (unless (eq package old-package)
18.197+ (let ((overwritten-symbol-shadowing-p
18.198+ (and overwritten-symbol-status
18.199+ (symbol-shadowing-p overwritten-symbol package))))
18.200+ (note-package-fishiness
18.201+ :rehome-symbol name
18.202+ (when old-package (package-name old-package)) old-status (and shadowing t)
18.203+ (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
18.204+ (when old-package
18.205+ (if shadowing
18.206+ (shadowing-import* shadowing old-package))
18.207+ (unintern* symbol old-package))
18.208+ (cond
18.209+ (overwritten-symbol-shadowing-p
18.210+ (shadowing-import* symbol package))
18.211+ (t
18.212+ (when overwritten-symbol-status
18.213+ (unintern* overwritten-symbol package))
18.214+ (import* symbol package)))
18.215+ (if shadowing
18.216+ (shadowing-import* symbol old-package)
18.217+ (import* symbol old-package))
18.218+ #+(or clisp clozure)
18.219+ (multiple-value-bind (setf-symbol kind)
18.220+ (get-setf-function-symbol symbol)
18.221+ (when kind
18.222+ (let* ((setf-function (fdefinition setf-symbol))
18.223+ (new-setf-symbol (create-setf-function-symbol symbol)))
18.224+ (note-package-fishiness
18.225+ :setf-function
18.226+ name (package-name package)
18.227+ (symbol-name setf-symbol) (symbol-package-name setf-symbol)
18.228+ (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
18.229+ (when (symbol-package setf-symbol)
18.230+ (unintern* setf-symbol (symbol-package setf-symbol)))
18.231+ (setf (fdefinition new-setf-symbol) setf-function)
18.232+ (set-setf-function-symbol new-setf-symbol symbol kind))))
18.233+ #+(or clisp clozure)
18.234+ (multiple-value-bind (overwritten-setf foundp)
18.235+ (get-setf-function-symbol overwritten-symbol)
18.236+ (when foundp
18.237+ (unintern overwritten-setf)))
18.238+ (when (eq old-status :external)
18.239+ (export* symbol old-package))
18.240+ (when (eq overwritten-symbol-status :external)
18.241+ (export* symbol package))))
18.242+ (values overwritten-symbol overwritten-symbol-status))))
18.243+ (defun ensure-package-unused (package)
18.244+ (loop :for p :in (package-used-by-list package) :do
18.245+ (unuse-package package p)))
18.246+ (defun delete-package* (package &key nuke)
18.247+ (let ((p (find-package package)))
18.248+ (when p
18.249+ (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
18.250+ (ensure-package-unused p)
18.251+ (delete-package package))))
18.252+ (defun package-names (package)
18.253+ (cons (package-name package) (package-nicknames package)))
18.254+ (defun packages-from-names (names)
18.255+ (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
18.256+ (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
18.257+ separator
18.258+ (index (random most-positive-fixnum)))
18.259+ (loop :for i :from index
18.260+ :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
18.261+ :thereis (and (not (find-package n)) n)))
18.262+ (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
18.263+ (let ((new-name
18.264+ (apply 'fresh-package-name
18.265+ :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
18.266+ (record-fishy (list :rename-away (package-names p) new-name))
18.267+ (rename-package p new-name))))
18.268+
18.269+
18.270+;;; Communicable representation of symbol and package information
18.271+
18.272+(eval-when (:load-toplevel :compile-toplevel :execute)
18.273+ (defun package-definition-form (package-designator
18.274+ &key (nicknamesp t) (usep t)
18.275+ (shadowp t) (shadowing-import-p t)
18.276+ (exportp t) (importp t) internp (error t))
18.277+ (let* ((package (or (find-package* package-designator error)
18.278+ (return-from package-definition-form nil)))
18.279+ (name (package-name package))
18.280+ (nicknames (package-nicknames package))
18.281+ (use (mapcar #'package-name (package-use-list package)))
18.282+ (shadow ())
18.283+ (shadowing-import (make-hash-table :test 'equal))
18.284+ (import (make-hash-table :test 'equal))
18.285+ (export ())
18.286+ (intern ()))
18.287+ (when package
18.288+ (loop :for sym :being :the :symbols :in package
18.289+ :for status = (nth-value 1 (find-symbol* sym package)) :do
18.290+ (ecase status
18.291+ ((nil :inherited))
18.292+ ((:internal :external)
18.293+ (let* ((name (symbol-name sym))
18.294+ (external (eq status :external))
18.295+ (home (symbol-package sym))
18.296+ (home-name (package-name home))
18.297+ (imported (not (eq home package)))
18.298+ (shadowing (symbol-shadowing-p sym package)))
18.299+ (cond
18.300+ ((and shadowing imported)
18.301+ (push name (gethash home-name shadowing-import)))
18.302+ (shadowing
18.303+ (push name shadow))
18.304+ (imported
18.305+ (push name (gethash home-name import))))
18.306+ (cond
18.307+ (external
18.308+ (push name export))
18.309+ (imported)
18.310+ (t (push name intern)))))))
18.311+ (labels ((sort-names (names)
18.312+ (sort (copy-list names) #'string<))
18.313+ (table-keys (table)
18.314+ (loop :for k :being :the :hash-keys :of table :collect k))
18.315+ (when-relevant (key value)
18.316+ (when value (list (cons key value))))
18.317+ (import-options (key table)
18.318+ (loop :for i :in (sort-names (table-keys table))
18.319+ :collect `(,key ,i ,@(sort-names (gethash i table))))))
18.320+ `(defpackage ,name
18.321+ ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
18.322+ (:use ,@(and usep (sort-names use)))
18.323+ ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
18.324+ ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
18.325+ ,@(import-options :import-from (and importp import))
18.326+ ,@(when-relevant :export (and exportp (sort-names export)))
18.327+ ,@(when-relevant :intern (and internp (sort-names intern)))))))))
18.328+
18.329+(eval-when (:load-toplevel :compile-toplevel :execute)
18.330+ (defun ensure-shadowing-import (name to-package from-package shadowed imported)
18.331+ (check-type name string)
18.332+ (check-type to-package package)
18.333+ (check-type from-package package)
18.334+ (check-type shadowed hash-table)
18.335+ (check-type imported hash-table)
18.336+ (let ((import-me (find-symbol* name from-package)))
18.337+ (multiple-value-bind (existing status) (find-symbol name to-package)
18.338+ (cond
18.339+ ((gethash name shadowed)
18.340+ (unless (eq import-me existing)
18.341+ (error "Conflicting shadowings for ~A" name)))
18.342+ (t
18.343+ (setf (gethash name shadowed) t)
18.344+ (setf (gethash name imported) t)
18.345+ (unless (or (null status)
18.346+ (and (member status '(:internal :external))
18.347+ (eq existing import-me)
18.348+ (symbol-shadowing-p existing to-package)))
18.349+ (note-package-fishiness
18.350+ :shadowing-import name
18.351+ (package-name from-package)
18.352+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
18.353+ (package-name to-package) status
18.354+ (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
18.355+ (shadowing-import* import-me to-package))))))
18.356+ (defun ensure-imported (import-me into-package &optional from-package)
18.357+ (check-type import-me symbol)
18.358+ (check-type into-package package)
18.359+ (check-type from-package (or null package))
18.360+ (let ((name (symbol-name import-me)))
18.361+ (multiple-value-bind (existing status) (find-symbol name into-package)
18.362+ (cond
18.363+ ((not status)
18.364+ (import* import-me into-package))
18.365+ ((eq import-me existing))
18.366+ (t
18.367+ (let ((shadowing-p (symbol-shadowing-p existing into-package)))
18.368+ (note-package-fishiness
18.369+ :ensure-imported name
18.370+ (and from-package (package-name from-package))
18.371+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
18.372+ (package-name into-package)
18.373+ status
18.374+ (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
18.375+ shadowing-p)
18.376+ (cond
18.377+ ((or shadowing-p (eq status :inherited))
18.378+ (shadowing-import* import-me into-package))
18.379+ (t
18.380+ (unintern* existing into-package)
18.381+ (import* import-me into-package))))))))
18.382+ (values))
18.383+ (defun ensure-import (name to-package from-package shadowed imported)
18.384+ (check-type name string)
18.385+ (check-type to-package package)
18.386+ (check-type from-package package)
18.387+ (check-type shadowed hash-table)
18.388+ (check-type imported hash-table)
18.389+ (multiple-value-bind (import-me import-status) (find-symbol name from-package)
18.390+ (when (null import-status)
18.391+ (note-package-fishiness
18.392+ :import-uninterned name (package-name from-package) (package-name to-package))
18.393+ (setf import-me (intern* name from-package)))
18.394+ (multiple-value-bind (existing status) (find-symbol name to-package)
18.395+ (cond
18.396+ ((and imported (gethash name imported))
18.397+ (unless (and status (eq import-me existing))
18.398+ (error "Can't import ~S from both ~S and ~S"
18.399+ name (package-name (symbol-package existing)) (package-name from-package))))
18.400+ ((gethash name shadowed)
18.401+ (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
18.402+ (t
18.403+ (setf (gethash name imported) t))))
18.404+ (ensure-imported import-me to-package from-package)))
18.405+ (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
18.406+ (check-type name string)
18.407+ (check-type symbol symbol)
18.408+ (check-type to-package package)
18.409+ (check-type from-package package)
18.410+ (check-type mixp (member nil t)) ; no cl:boolean on Genera
18.411+ (check-type shadowed hash-table)
18.412+ (check-type imported hash-table)
18.413+ (check-type inherited hash-table)
18.414+ (multiple-value-bind (existing status) (find-symbol name to-package)
18.415+ (let* ((sp (symbol-package symbol))
18.416+ (in (gethash name inherited))
18.417+ (xp (and status (symbol-package existing))))
18.418+ (when (null sp)
18.419+ (note-package-fishiness
18.420+ :import-uninterned name
18.421+ (package-name from-package) (package-name to-package) mixp)
18.422+ (import* symbol from-package)
18.423+ (setf sp (package-name from-package)))
18.424+ (cond
18.425+ ((gethash name shadowed))
18.426+ (in
18.427+ (unless (equal sp (first in))
18.428+ (if mixp
18.429+ (ensure-shadowing-import name to-package (second in) shadowed imported)
18.430+ (error "Can't inherit ~S from ~S, it is inherited from ~S"
18.431+ name (package-name sp) (package-name (first in))))))
18.432+ ((gethash name imported)
18.433+ (unless (eq symbol existing)
18.434+ (error "Can't inherit ~S from ~S, it is imported from ~S"
18.435+ name (package-name sp) (package-name xp))))
18.436+ (t
18.437+ (setf (gethash name inherited) (list sp from-package))
18.438+ (when (and status (not (eq sp xp)))
18.439+ (let ((shadowing (symbol-shadowing-p existing to-package)))
18.440+ (note-package-fishiness
18.441+ :inherited name
18.442+ (package-name from-package)
18.443+ (or (home-package-p symbol from-package) (symbol-package-name symbol))
18.444+ (package-name to-package)
18.445+ (or (home-package-p existing to-package) (symbol-package-name existing)))
18.446+ (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
18.447+ (unintern* existing to-package)))))))))
18.448+ (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
18.449+ (check-type name string)
18.450+ (check-type symbol symbol)
18.451+ (check-type to-package package)
18.452+ (check-type from-package package)
18.453+ (check-type shadowed hash-table)
18.454+ (check-type imported hash-table)
18.455+ (check-type inherited hash-table)
18.456+ (unless (gethash name shadowed)
18.457+ (multiple-value-bind (existing status) (find-symbol name to-package)
18.458+ (let* ((sp (symbol-package symbol))
18.459+ (im (gethash name imported))
18.460+ (in (gethash name inherited)))
18.461+ (cond
18.462+ ((or (null status)
18.463+ (and status (eq symbol existing))
18.464+ (and in (eq sp (first in))))
18.465+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
18.466+ (in
18.467+ (remhash name inherited)
18.468+ (ensure-shadowing-import name to-package (second in) shadowed imported))
18.469+ (im
18.470+ (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
18.471+ name (package-name from-package)
18.472+ (home-package-p symbol from-package) (symbol-package-name symbol)
18.473+ (package-name to-package)
18.474+ (home-package-p existing to-package) (symbol-package-name existing)))
18.475+ (t
18.476+ (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
18.477+
18.478+ (defun recycle-symbol (name recycle exported)
18.479+ ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
18.480+ ;; packages, and a hash-table of names (strings) of symbols scheduled to be
18.481+ ;; EXPORTED from the package being defined. It returns two values, the
18.482+ ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
18.483+ ;; a symbol was found. The caller (DEFPKG) will then do the
18.484+ ;; re-homing of the symbol, etc.
18.485+ (check-type name string)
18.486+ (check-type recycle list)
18.487+ (check-type exported hash-table)
18.488+ (when (gethash name exported) ;; don't bother recycling private symbols
18.489+ (let (recycled foundp)
18.490+ (dolist (r recycle (values recycled foundp))
18.491+ (multiple-value-bind (symbol status) (find-symbol name r)
18.492+ (when (and status (home-package-p symbol r))
18.493+ (cond
18.494+ (foundp
18.495+ ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
18.496+ (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
18.497+ (t
18.498+ (setf recycled symbol foundp r)))))))))
18.499+ (defun symbol-recycled-p (sym recycle)
18.500+ (check-type sym symbol)
18.501+ (check-type recycle list)
18.502+ (and (member (symbol-package sym) recycle) t))
18.503+ (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
18.504+ (check-type name string)
18.505+ (check-type package package)
18.506+ (check-type intern (member nil t)) ; no cl:boolean on Genera
18.507+ (check-type shadowed hash-table)
18.508+ (check-type imported hash-table)
18.509+ (check-type inherited hash-table)
18.510+ (unless (or (gethash name shadowed)
18.511+ (gethash name imported)
18.512+ (gethash name inherited))
18.513+ (multiple-value-bind (existing status)
18.514+ (find-symbol name package)
18.515+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
18.516+ (cond
18.517+ ((and status (eq existing recycled) (eq previous package)))
18.518+ (previous
18.519+ (rehome-symbol recycled package))
18.520+ ((and status (eq package (symbol-package existing))))
18.521+ (t
18.522+ (when status
18.523+ (note-package-fishiness
18.524+ :ensure-symbol name
18.525+ (reify-package (symbol-package existing) package)
18.526+ status intern)
18.527+ (unintern existing))
18.528+ (when intern
18.529+ (intern* name package))))))))
18.530+ (declaim (ftype (function (t t t &optional t) t) ensure-exported))
18.531+ (defun ensure-exported-to-user (name symbol to-package &optional recycle)
18.532+ (check-type name string)
18.533+ (check-type symbol symbol)
18.534+ (check-type to-package package)
18.535+ (check-type recycle list)
18.536+ (assert (equal name (symbol-name symbol)))
18.537+ (multiple-value-bind (existing status) (find-symbol name to-package)
18.538+ (unless (and status (eq symbol existing))
18.539+ (let ((accessible
18.540+ (or (null status)
18.541+ (let ((shadowing (symbol-shadowing-p existing to-package))
18.542+ (recycled (symbol-recycled-p existing recycle)))
18.543+ (unless (and shadowing (not recycled))
18.544+ (note-package-fishiness
18.545+ :ensure-export name (symbol-package-name symbol)
18.546+ (package-name to-package)
18.547+ (or (home-package-p existing to-package) (symbol-package-name existing))
18.548+ status shadowing)
18.549+ (if (or (eq status :inherited) shadowing)
18.550+ (shadowing-import* symbol to-package)
18.551+ (unintern existing to-package))
18.552+ t)))))
18.553+ (when (and accessible (eq status :external))
18.554+ (ensure-exported name symbol to-package recycle))))))
18.555+ (defun ensure-exported (name symbol from-package &optional recycle)
18.556+ (dolist (to-package (package-used-by-list from-package))
18.557+ (ensure-exported-to-user name symbol to-package recycle))
18.558+ (unless (eq from-package (symbol-package symbol))
18.559+ (ensure-imported symbol from-package))
18.560+ (export* name from-package))
18.561+ (defun ensure-export (name from-package &optional recycle)
18.562+ (multiple-value-bind (symbol status) (find-symbol* name from-package)
18.563+ (unless (eq status :external)
18.564+ (ensure-exported name symbol from-package recycle))))
18.565+
18.566+ (defun ensure-package (name &key
18.567+ nicknames documentation use
18.568+ shadow shadowing-import-from
18.569+ import-from export intern
18.570+ recycle mix reexport
18.571+ unintern)
18.572+ #+genera (declare (ignore documentation))
18.573+ (let* ((package-name (string name))
18.574+ (nicknames (mapcar #'string nicknames))
18.575+ (names (cons package-name nicknames))
18.576+ (previous (packages-from-names names))
18.577+ (discarded (cdr previous))
18.578+ (to-delete ())
18.579+ (package (or (first previous) (make-package package-name :nicknames nicknames)))
18.580+ (recycle (packages-from-names recycle))
18.581+ (use (mapcar 'find-package* use))
18.582+ (mix (mapcar 'find-package* mix))
18.583+ (reexport (mapcar 'find-package* reexport))
18.584+ (shadow (mapcar 'string shadow))
18.585+ (export (mapcar 'string export))
18.586+ (intern (mapcar 'string intern))
18.587+ (unintern (mapcar 'string unintern))
18.588+ (shadowed (make-hash-table :test 'equal)) ; string to bool
18.589+ (imported (make-hash-table :test 'equal)) ; string to bool
18.590+ (exported (make-hash-table :test 'equal)) ; string to bool
18.591+ ;; string to list home package and use package:
18.592+ (inherited (make-hash-table :test 'equal)))
18.593+ (when-package-fishiness (record-fishy package-name))
18.594+ #-genera
18.595+ (when documentation (setf (documentation package t) documentation))
18.596+ (loop :for p :in (set-difference (package-use-list package) (append mix use))
18.597+ :do (note-package-fishiness :over-use name (package-names p))
18.598+ (unuse-package p package))
18.599+ (loop :for p :in discarded
18.600+ :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
18.601+ (package-names p))
18.602+ :do (note-package-fishiness :nickname name (package-names p))
18.603+ (cond (n (rename-package p (first n) (rest n)))
18.604+ (t (rename-package-away p)
18.605+ (push p to-delete))))
18.606+ (rename-package package package-name nicknames)
18.607+ (dolist (name unintern)
18.608+ (multiple-value-bind (existing status) (find-symbol name package)
18.609+ (when status
18.610+ (unless (eq status :inherited)
18.611+ (note-package-fishiness
18.612+ :unintern (package-name package) name (symbol-package-name existing) status)
18.613+ (unintern* name package nil)))))
18.614+ (dolist (name export)
18.615+ (setf (gethash name exported) t))
18.616+ (dolist (p reexport)
18.617+ (do-external-symbols (sym p)
18.618+ (setf (gethash (string sym) exported) t)))
18.619+ (do-external-symbols (sym package)
18.620+ (let ((name (symbol-name sym)))
18.621+ (unless (gethash name exported)
18.622+ (note-package-fishiness
18.623+ :over-export (package-name package) name
18.624+ (or (home-package-p sym package) (symbol-package-name sym)))
18.625+ (unexport sym package))))
18.626+ (dolist (name shadow)
18.627+ (setf (gethash name shadowed) t)
18.628+ (multiple-value-bind (existing status) (find-symbol name package)
18.629+ (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
18.630+ (let ((shadowing (and status (symbol-shadowing-p existing package))))
18.631+ (cond
18.632+ ((eq previous package))
18.633+ (previous
18.634+ (rehome-symbol recycled package))
18.635+ ((or (member status '(nil :inherited))
18.636+ (home-package-p existing package)))
18.637+ (t
18.638+ (let ((dummy (make-symbol name)))
18.639+ (note-package-fishiness
18.640+ :shadow-imported (package-name package) name
18.641+ (symbol-package-name existing) status shadowing)
18.642+ (shadowing-import* dummy package)
18.643+ (import* dummy package)))))))
18.644+ (shadow* name package))
18.645+ (loop :for (p . syms) :in shadowing-import-from
18.646+ :for pp = (find-package* p) :do
18.647+ (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
18.648+ (loop :for p :in mix
18.649+ :for pp = (find-package* p) :do
18.650+ (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
18.651+ (loop :for (p . syms) :in import-from
18.652+ :for pp = (find-package p) :do
18.653+ (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
18.654+ (dolist (p (append use mix))
18.655+ (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
18.656+ (use-package p package))
18.657+ (loop :for name :being :the :hash-keys :of exported :do
18.658+ (ensure-symbol name package t recycle shadowed imported inherited exported)
18.659+ (ensure-export name package recycle))
18.660+ (dolist (name intern)
18.661+ (ensure-symbol name package t recycle shadowed imported inherited exported))
18.662+ (do-symbols (sym package)
18.663+ (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
18.664+ (map () 'delete-package* to-delete)
18.665+ package)))
18.666+
18.667+(eval-when (:load-toplevel :compile-toplevel :execute)
18.668+ (defun parse-defpkg-form (package clauses)
18.669+ (loop
18.670+ :with use-p = nil :with recycle-p = nil
18.671+ :with documentation = nil
18.672+ :for (kw . args) :in clauses
18.673+ :when (eq kw :nicknames) :append args :into nicknames :else
18.674+ :when (eq kw :documentation)
18.675+ :do (cond
18.676+ (documentation (error "defpkg: can't define documentation twice"))
18.677+ ((or (atom args) (cdr args)) (error "defpkg: bad documentation"))
18.678+ (t (setf documentation (car args)))) :else
18.679+ :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
18.680+ :when (eq kw :shadow) :append args :into shadow :else
18.681+ :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
18.682+ :when (eq kw :import-from) :collect args :into import-from :else
18.683+ :when (eq kw :export) :append args :into export :else
18.684+ :when (eq kw :intern) :append args :into intern :else
18.685+ :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
18.686+ :when (eq kw :mix) :append args :into mix :else
18.687+ :when (eq kw :reexport) :append args :into reexport :else
18.688+ :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
18.689+ :and :do (setf use-p t) :else
18.690+ :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
18.691+ :and :do (setf use-p t) :else
18.692+ :when (eq kw :unintern) :append args :into unintern :else
18.693+ :do (error "unrecognized defpkg keyword ~S" kw)
18.694+ :finally (return `(,package
18.695+ :nicknames ,nicknames :documentation ,documentation
18.696+ :use ,(if use-p use '(:common-lisp))
18.697+ :shadow ,shadow :shadowing-import-from ,shadowing-import-from
18.698+ :import-from ,import-from :export ,export :intern ,intern
18.699+ :recycle ,(if recycle-p recycle (cons package nicknames))
18.700+ :mix ,mix :reexport ,reexport :unintern ,unintern)))))
18.701+
18.702+(defmacro defpkg (package &rest clauses)
18.703+ "Richard's Robust DEFPACKAGE macro. Based on UIOP:DEFINE-PACKAGE. ymmv.
18.704+
18.705+DEFPKG takes a PACKAGE and a number of CLAUSES, of the form (KEYWORD . ARGS).
18.706+
18.707+DEFPKG supports the following keywords:
18.708+USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
18.709+
18.710+DEFPKG also redefines the following extensions:
18.711+RECYCLE, MIX, REEXPORT, UNINTERN -- as per UIOP/PACKAGE:DEFINE-PACKAGE
18.712+
18.713+REEXPORT -- Takes a list of package designators. For each package in
18.714+the list, export symbols with the same name as those exported from
18.715+that package. In the case of shadowing, etc. They may not be EQL."
18.716+ (let ((ensure-form
18.717+ `(apply 'ensure-package ',(parse-defpkg-form package clauses))))
18.718+ `(progn
18.719+ #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
18.720+ (eval-when (:compile-toplevel :load-toplevel :execute)
18.721+ ,ensure-form))))
18.722+
18.723+(provide :pkg)
19.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
19.2+++ b/lisp/std/str.lisp Mon Oct 16 19:33:42 2023 -0400
19.3@@ -0,0 +1,36 @@
19.4+;;; std/str.lisp --- String utilities
19.5+
19.6+;;; Code:
19.7+
19.8+;; (defvar sb-unicode-syms
19.9+;; '(words lines sentences whitespace-p uppercase lowercase titlecase
19.10+;; word-break-class line-break-class sentence-break-class char-block
19.11+;; cased-p uppercase-p lowercase-p titlecase-p casefold
19.12+;; graphemes grapheme-break-class
19.13+;; bidi-mirroring-glyph bidi-class
19.14+;; normalize-string normalized-p default-ignorable-p
19.15+;; confusable-p hex-digit-p mirrored-p alphabetic-p math-p
19.16+;; decimal-value digit-value
19.17+;; unicode< unicode> unicode= unicode-equal
19.18+;; unicode<= unicode>=))
19.19+
19.20+(defpackage :std/str
19.21+ (:use :cl :uiop/driver :sb-unicode)
19.22+ (:nicknames :str)
19.23+ (:export
19.24+ #:string-designator))
19.25+
19.26+(in-package :str)
19.27+
19.28+;; (mapc (lambda (s) (export s)) sb-unicode-syms)
19.29+;; (reexport-from
19.30+;; :sb-unicode
19.31+;; :include sb-unicode-syms)
19.32+
19.33+(deftype string-designator ()
19.34+ "A string designator type. A string designator is either a string, a symbol,
19.35+or a character."
19.36+ `(or symbol string character))
19.37+;;; TODO 2023-08-27: camel snake kebab
19.38+
19.39+;;; format recipes
20.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
20.2+++ b/lisp/std/sym.lisp Mon Oct 16 19:33:42 2023 -0400
20.3@@ -0,0 +1,90 @@
20.4+;;; sym.lisp --- Symbol utils
20.5+
20.6+;; inspired by alexandria/symbols.lisp
20.7+
20.8+;;; Code:
20.9+(pkg:defpkg :std/sym
20.10+ (:use :cl :str :sb-int)
20.11+ (:nicknames :sym)
20.12+ (:export
20.13+ #:ensure-symbol
20.14+ #:format-symbol
20.15+ #:make-keyword
20.16+ #:make-slot-name
20.17+ #:make-gensym
20.18+ #:make-gensym-list
20.19+ #:with-gensyms
20.20+ #:with-unique-names
20.21+ #:symbolicate))
20.22+
20.23+(in-package :sym)
20.24+
20.25+;; (reexport-from :sb-int
20.26+;; :include '(:with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*))
20.27+
20.28+;; On SBCL, `with-unique-names' is defined under
20.29+;; src/code/primordial-extensions.lisp. We use that instead of
20.30+;; defining our own.
20.31+(setf (macro-function 'with-gensyms) (macro-function 'with-unique-names))
20.32+
20.33+(declaim (inline ensure-symbol))
20.34+(defun ensure-symbol (name &optional (package *package*))
20.35+ "Returns a symbol with name designated by NAME, accessible in package
20.36+designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
20.37+interned there. Returns a secondary value reflecting the status of the symbol
20.38+in the package, which matches the secondary return value of INTERN.
20.39+
20.40+Example:
20.41+
20.42+ (ensure-symbol :cons :cl) => cl:cons, :external
20.43+"
20.44+ (intern (string name) package))
20.45+
20.46+(defun maybe-intern (name package)
20.47+ (values
20.48+ (if package
20.49+ (intern name (if (eq t package) *package* package))
20.50+ (make-symbol name))))
20.51+
20.52+(declaim (inline format-symbol))
20.53+(defun format-symbol (package control &rest arguments)
20.54+ "Constructs a string by applying ARGUMENTS to string designator CONTROL as
20.55+if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
20.56+by that string.
20.57+
20.58+If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
20.59+symbol interned in the current package, and otherwise returns a symbol
20.60+interned in the package designated by PACKAGE."
20.61+ (maybe-intern (with-standard-io-syntax
20.62+ (apply #'format nil (string control) arguments))
20.63+ package))
20.64+
20.65+(defun make-keyword (name)
20.66+ "Interns the string designated by NAME in the KEYWORD package."
20.67+ (intern (string name) :keyword))
20.68+
20.69+(defmacro make-slot-name (name)
20.70+ "make slot-name"
20.71+ `(intern ,(string-upcase name) :keyword))
20.72+
20.73+(defun make-gensym (name)
20.74+ "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
20.75+must be a string designator, in which case calls GENSYM using the designated
20.76+string as the argument."
20.77+ (gensym (if (typep name '(integer 0))
20.78+ name
20.79+ (string name))))
20.80+
20.81+(sb-ext:with-unlocked-packages (:sb-int)
20.82+ (handler-bind
20.83+ ((sb-kernel:redefinition-warning #'muffle-warning))
20.84+ (defun make-gensym-list (length &optional (x "G"))
20.85+ "Returns a list of LENGTH gensyms, each generated as if with a call to
20.86+MAKE-GENSYM, using the second (optional, defaulting to \"G\")
20.87+argument. This function is implemented in SBCL
20.88+src/code/primordial-extensions.lisp but re-implemented here. The only
20.89+difference is that we also handle non-zero integers, which can be
20.90+passed as the first argument to `gensym'."
20.91+ (let ((g (if (typep x '(integer 0)) x (string x))))
20.92+ (loop repeat length
20.93+ collect (gensym g))))))
21.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
21.2+++ b/lisp/std/tests.lisp Mon Oct 16 19:33:42 2023 -0400
21.3@@ -0,0 +1,131 @@
21.4+;;; tests.lisp --- macs system tests
21.5+
21.6+;;; Commentary:
21.7+
21.8+;; TODO: fix false positives when using (eval-test)
21.9+
21.10+;;; Code:
21.11+(defpackage :std/tests
21.12+ (:use
21.13+ :cl
21.14+ :readtables
21.15+ :str
21.16+ :fmt
21.17+ :sym
21.18+ :list
21.19+ :cond
21.20+ :log
21.21+ :fu
21.22+ :ana
21.23+ :pan
21.24+ :fs
21.25+ :alien
21.26+ :thread
21.27+ :rt))
21.28+
21.29+(in-package :std/tests)
21.30+
21.31+(in-readtable :std)
21.32+
21.33+;;; READTABLES
21.34+(defsuite :named-readtables)
21.35+(in-suite :named-readtables)
21.36+(deftest readtables ()
21.37+ "Test :std readtable without cl-ppcre"
21.38+ (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
21.39+ (is (string= #"test "foo" "# "test \"foo\" "))
21.40+ (is (string= #$test "1 2 3"$# "test \"1 2 3\"")))
21.41+
21.42+#+cl-ppcre
21.43+(deftest ppcre-readtables (:persist t)
21.44+ "Test *macs-readtable* with cl-ppcre"
21.45+ (is (= 1 1)))
21.46+
21.47+;;; STD
21.48+(defsuite :std)
21.49+(in-suite :std)
21.50+
21.51+(deftest sym ()
21.52+ "Test STD.SYM"
21.53+ ;; gensyms
21.54+ (is (not (equalp (make-gensym 'a) (make-gensym 'a))))
21.55+ (is (eq (ensure-symbol 'tests :macs.tests) 'tests))
21.56+ (is (eq 'macs.tests::foo (format-symbol :macs.tests "~A" 'foo)))
21.57+ (is (eq (make-keyword 'fizz) :fizz)))
21.58+
21.59+;;;; TODO
21.60+(deftest str ()
21.61+ "Test STD.STR"
21.62+ (is (typep "test" 'string-designator))
21.63+ (is (typep 'test 'string-designator))
21.64+ (is (typep #\C 'string-designator))
21.65+ (is (not (typep 0 'string-designator))))
21.66+
21.67+(deftest list ()
21.68+ "Test STD.LIST"
21.69+ ;; same object - a literal
21.70+ (is (eq (ensure-car '(0)) (ensure-car 0)))
21.71+ (is (eq (ensure-car '(nil)) (ensure-car nil)))
21.72+ ;; different objects
21.73+ (is (not (eq (ensure-cons 0) (ensure-cons 0))))
21.74+ (is (equal (ensure-cons 0) (ensure-cons 0))))
21.75+
21.76+(deftest log ()
21.77+ "Test STD.LONG"
21.78+ (is (debug! "test" *log-level*)))
21.79+
21.80+(deftest cond ()
21.81+ "Test STD.COND")
21.82+
21.83+(deftest thread ()
21.84+ "Test STD.THREAD"
21.85+ (is (stringp (print-thread-info nil))))
21.86+
21.87+(deftest alien ()
21.88+ "Test STD.ALIEN"
21.89+ (is (= 0 (foreign-int-to-integer 0 4)))
21.90+ (is (= 1 (bool-to-foreign-int t))))
21.91+
21.92+(deftest fmt ()
21.93+ "Test STD.FMT"
21.94+ (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3))))
21.95+ (is (string= (fmt-sxhash (sxhash t)) (fmt-sxhash (sxhash t))))
21.96+ (is (string=
21.97+ ;; note the read-time-eval..
21.98+ #.(fmt-tree nil '(foobar (:a) (:b) (c) (d)) :layout :down)
21.99+ #"FOOBAR
21.100+ ├─ :A
21.101+ ├─ :B
21.102+ ├─ C
21.103+ ╰─ D
21.104+"#))
21.105+;; with plist option
21.106+ (is (string=
21.107+ #.(fmt:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
21.108+ #"SK-PROJECT
21.109+ ├─ :NAME
21.110+ │ ╰─ "foobar"
21.111+ ├─ :PATH
21.112+ │ ╰─ "/a/b/c.asd"
21.113+ ╰─ :VC
21.114+ ╰─ :HG
21.115+"#)))
21.116+
21.117+(deftest ana ()
21.118+ "Test STD.ANA"
21.119+ (is (= 8
21.120+ (aif (+ 2 2)
21.121+ (+ it it)))))
21.122+
21.123+(deftest pan ()
21.124+ "Test STD.PAN"
21.125+ (let ((p
21.126+ (plambda (a) (b c)
21.127+ (if (not a)
21.128+ (setq b 0
21.129+ c 0)
21.130+ (progn (incf b a) (incf c a))))))
21.131+ (with-pandoric (b c) p
21.132+ (is (= 0 (funcall p nil)))
21.133+ (is (= 1 (funcall p 1)))
21.134+ (is (= 1 b c)))))
22.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
22.2+++ b/lisp/std/thread.lisp Mon Oct 16 19:33:42 2023 -0400
22.3@@ -0,0 +1,56 @@
22.4+;;; threads.lisp --- Multi-thread utilities
22.5+
22.6+;; Threading Macros
22.7+
22.8+;;; Commentary:
22.9+
22.10+;; mostly yoinked from sb-thread and friends
22.11+
22.12+;;; Code:
22.13+(defpackage :std/thread
22.14+ (:use :cl :macs.alien :sb-thread)
22.15+ (:nicknames :thread)
22.16+ (:export
22.17+ :print-thread-info :print-thread-message-top-level :thread-support-p))
22.18+
22.19+(in-package :thread)
22.20+
22.21+;; (reexport-from :sb-thread
22.22+;; :include '(:main-thread
22.23+;; :*current-thread*
22.24+;; :list-all-threads
22.25+;; :thread
22.26+;; :thread-alive-p
22.27+;; :thread-name
22.28+;; :thread-error
22.29+;; :thread-yield
22.30+;; :make-thread
22.31+;; :join-thread
22.32+;; :destroy-thread
22.33+;; :interrupt-thread
22.34+;; :semaphore
22.35+;; :get-semaphore
22.36+;; :make-semaphore
22.37+;; :mutex
22.38+;; :get-mutex
22.39+;; :make-mutex
22.40+;; :spinlock
22.41+;; :get-spinlock
22.42+;; :make-spinlock))
22.43+
22.44+(defun thread-support-p () (member :thread-support *features*))
22.45+
22.46+(defun print-thread-info (&optional (stream *standard-output*))
22.47+ (let* ((curr-thread sb-thread:*current-thread*)
22.48+ (curr-thread-name (sb-thread:thread-name curr-thread))
22.49+ (all-threads (sb-thread:list-all-threads)))
22.50+ (format stream "Current thread: ~a~%~%" curr-thread)
22.51+ (format stream "Current thread name: ~a~%~%" curr-thread-name)
22.52+ (format stream "All threads:~% ~{~a~%~}~%" all-threads)))
22.53+
22.54+(eval-when (:compile-toplevel)
22.55+ (defun print-thread-message-top-level (msg)
22.56+ (sb-thread:make-thread
22.57+ (lambda ()
22.58+ (format #.*standard-output* msg)))
22.59+ nil))
