1.1--- a/lisp/ffi/uring/util.lisp Sun Apr 21 22:38:49 2024 -0400
1.2+++ b/lisp/ffi/uring/util.lisp Mon Apr 22 23:14:47 2024 -0400
1.3@@ -60,3 +60,10 @@
1.4
1.5 ;; do-mmap
1.6 ;; map len bytes starting from offset from file-descriptor in mmapped-region
1.7+
1.8+;;; CPU Affinity
1.9+;; it appears this actually crashes SBCL, receiving sig6 from foreign thread
1.10+;; (define-alien-routine sched-setaffinity int (pid int) (cpusetsize size-t) (set (* (struct cpu-set-t))))
1.11+;; (define-alien-routine sched-getaffinity int (pid int) (cpusetsize size-t) (set (* (struct cpu-set-t))))
1.12+;; (sched-getaffinity 0 cpu-setsize (make-alien (struct cpu-set-t)))
1.13+;; (sched-setaffinity 0 cpu-setsize (make-alien (struct cpu-set-t)))
2.1--- a/lisp/std/alien.lisp Sun Apr 21 22:38:49 2024 -0400
2.2+++ b/lisp/std/alien.lisp Mon Apr 22 23:14:47 2024 -0400
2.3@@ -21,7 +21,7 @@
2.4 ;; represented by objects of type ALIEN-VALUE.
2.5
2.6 ;;; Code:
2.7-(in-package :std)
2.8+(in-package :std/alien)
2.9 (shadowing-import
2.10 '(sb-unix::syscall sb-unix::syscall* sb-unix::int-syscall
2.11 sb-unix::with-restarted-syscall sb-unix::void-syscall) :std)
3.1--- a/lisp/std/ana.lisp Sun Apr 21 22:38:49 2024 -0400
3.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3@@ -1,84 +0,0 @@
3.4-;;; ana.lisp --- anaphoric macros
3.5-
3.6-;;; Code:
3.7-(in-package :std)
3.8-
3.9-(in-readtable :std)
3.10-
3.11-;; Graham's alambda
3.12-(defmacro alambda (parms &body body)
3.13- `(labels ((self ,parms ,@body))
3.14- #'self))
3.15-
3.16-;; Graham's aif
3.17-(defmacro aif (test then &optional else)
3.18- `(let ((it ,test))
3.19- (if it ,then ,else)))
3.20-
3.21-;; ;; TODO 2023-09-05: wrap, document, optimize, hack
3.22-;; re-exported from SB-INT
3.23-(defmacro awhen (test &body body)
3.24- `(let ((it ,test))
3.25- (when it ,@body)))
3.26-
3.27-(defmacro acond (&rest clauses)
3.28- (if (null clauses)
3.29- `()
3.30- (destructuring-bind ((test &body body) &rest rest) clauses
3.31- (let ((it (copy-symbol 'it)))
3.32- `(let ((,it ,test))
3.33- (if ,it
3.34- ;; Just like COND - no body means return the tested value.
3.35- ,(if body
3.36- `(let ((it ,it)) (declare (ignorable it)) ,@body)
3.37- it)
3.38- (acond ,@rest)))))))
3.39-
3.40-(defmacro! nlet-tail (n letargs &body body)
3.41- (let ((gs (loop for i in letargs
3.42- collect (gensym))))
3.43- `(macrolet
3.44- ((,n ,gs
3.45- `(progn
3.46- (psetq
3.47- ,@(apply #'nconc
3.48- (mapcar
3.49- #'list
3.50- ',(mapcar #'car letargs)
3.51- (list ,@gs))))
3.52- (go ,',g!n))))
3.53- (block ,g!b
3.54- (let ,letargs
3.55- (tagbody
3.56- ,g!n (return-from
3.57- ,g!b (progn ,@body))))))))
3.58-
3.59-(defmacro alet% (letargs &rest body)
3.60- `(let ((this) ,@letargs)
3.61- (setq this ,@(last body))
3.62- ,@(butlast body)
3.63- this))
3.64-
3.65-(defmacro alet (letargs &rest body)
3.66- `(let ((this) ,@letargs)
3.67- (setq this ,@(last body))
3.68- ,@(butlast body)
3.69- (lambda (&rest params)
3.70- (apply this params))))
3.71-
3.72-;; swiped from fiveam. This is just like acond except it assumes that
3.73-;; the TEST in each element of CLAUSES returns two values as opposed
3.74-;; to one.
3.75-(defmacro acond2 (&rest clauses)
3.76- (if (null clauses)
3.77- nil
3.78- (with-gensyms (val foundp)
3.79- (destructuring-bind ((test &rest progn) &rest others)
3.80- clauses
3.81- `(multiple-value-bind (,val ,foundp)
3.82- ,test
3.83- (if (or ,val ,foundp)
3.84- (let ((it ,val))
3.85- (declare (ignorable it))
3.86- ,@progn)
3.87- (acond2 ,@others)))))))
4.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/std/array.lisp Mon Apr 22 23:14:47 2024 -0400
4.3@@ -0,0 +1,24 @@
4.4+;;; std/array.lisp --- Standard Arrays
4.5+
4.6+;;
4.7+
4.8+;;; Code:
4.9+(in-package :std/array)
4.10+
4.11+(defun copy-array (array)
4.12+ (let ((new-array
4.13+ (make-array (array-dimensions array)
4.14+ :element-type (array-element-type array)
4.15+ :adjustable (adjustable-array-p array)
4.16+ :fill-pointer (and (array-has-fill-pointer-p array)
4.17+ (fill-pointer array)))))
4.18+ (loop for i below (array-total-size array)
4.19+ do (setf (row-major-aref new-array i)
4.20+ (row-major-aref array i)))
4.21+ new-array))
4.22+
4.23+(deftype signed-array-length ()
4.24+ "A (possibly negated) array length."
4.25+ '#.(let ((limit (1- array-dimension-limit)))
4.26+ `(integer ,(- limit) ,limit)))
4.27+
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/std/bit.lisp Mon Apr 22 23:14:47 2024 -0400
5.3@@ -0,0 +1,522 @@
5.4+;;; std/bit.lisp --- Bit manipulation
5.5+
5.6+;;; Commentary:
5.7+
5.8+;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html
5.9+
5.10+;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html
5.11+
5.12+;;; Code:
5.13+(in-package :std/bit)
5.14+
5.15+;;; Types
5.16+;; Bytes aren't necessarily 8 bits wide in Lisp. OCTET is always 8
5.17+;; bits.
5.18+(deftype octet () '(unsigned-byte 8))
5.19+(deftype octet-vector (&optional length)
5.20+ `(simple-array octet (,length)))
5.21+
5.22+;;; Bits
5.23+(defun make-bits (length &rest args)
5.24+ (apply #'make-array length (nconc (list :element-type 'bit) args)))
5.25+
5.26+;; https://graphics.stanford.edu/~seander/bithacks.html
5.27+;; http://www.azillionmonkeys.com/qed/asmexample.html
5.28+(defun haipart (n count)
5.29+ (declare (fixnum n count))
5.30+ (let ((x (abs n)))
5.31+ (if (minusp count)
5.32+ (ldb (byte (- count) 0) x)
5.33+ (ldb (byte count (max 0 (- (integer-length x) count)))
5.34+ x))))
5.35+
5.36+;; minusp = 38 bytes
5.37+
5.38+;; 29 bytes
5.39+(defun sign-bit (n)
5.40+ "compute the sign bit of a fixnum. If N < 0 return -1 else return 0."
5.41+ (declare (fixnum n))
5.42+ (ash n (- 0 (integer-length n))))
5.43+
5.44+;; 51 bytes (speed 3)
5.45+;; 67 bytes (speed 1)
5.46+(defun different-signs-p (x y)
5.47+ "Return non-nil iff x and y have opposite signs."
5.48+ (declare (fixnum x y) (optimize (speed 1)))
5.49+ (< (expt x y) 0))
5.50+
5.51+;; TODO 2024-02-23:
5.52+(defun mortify-bits (x y)
5.53+ "Interleave the bits of two numbers (Mortan numbers)."
5.54+ (declare (fixnum x y)
5.55+ (ignore x y))
5.56+ ;; (loop for i across (integer-length)
5.57+ ;; with z = 0
5.58+ ;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1);
5.59+ ;; do ()
5.60+ ;; return z)
5.61+ )
5.62+
5.63+(defun int-list-bits (n)
5.64+ (declare (fixnum n))
5.65+ (let ((bits '()))
5.66+ (dotimes (position (integer-length n) bits)
5.67+ (push (ldb (byte 1 position) n) bits))))
5.68+
5.69+(defun int-bit-vector (n)
5.70+ (declare (fixnum n))
5.71+ (let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t)))
5.72+ (dotimes (position (integer-length n) bits)
5.73+ (vector-push-extend (ldb (byte 1 position) n) bits))))
5.74+
5.75+(defun aref-bit (octets idx)
5.76+ (declare (octet-vector octets) (fixnum idx))
5.77+ (multiple-value-bind (octet-idx bit-idx)
5.78+ (truncate idx 8)
5.79+ (ldb (byte 1 bit-idx)
5.80+ (aref octets octet-idx))))
5.81+
5.82+(defun make-bit-vector (size &optional (fill 0))
5.83+ "Make a BIT-VECTOR with SIZE and initial-element FILL which must be a
5.84+BIT 0|1. Note that this representation is not as useful as you might
5.85+think - bit-vectors don't have a direct mapping to integers/fixnums --
5.86+they are vectors (AKA arrays) first, and bits second. Attempting to
5.87+perform bitwise-ops ends up being very inefficient so whenever
5.88+possible, stick with fixnums and use LOG* functions."
5.89+ (declare (bit fill))
5.90+ (make-array size :initial-element fill :adjustable nil :element-type 'bit))
5.91+
5.92+;; simple setter/getter for integer bits
5.93+(define-setf-expander logbit (index place &environment env)
5.94+ (multiple-value-bind (temps vals stores store-form access-form)
5.95+ (get-setf-expansion place env)
5.96+ (let ((i (gensym))
5.97+ (store (gensym))
5.98+ (stemp (first stores)))
5.99+ (values `(,i ,@temps)
5.100+ `(,index ,@vals)
5.101+ `(,store)
5.102+ `(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form))
5.103+ ,@(cdr stores))
5.104+ ,store-form
5.105+ ,store)
5.106+ `(logbit ,i ,access-form)))))
5.107+
5.108+(defun logbit (idx n)
5.109+ (declare (fixnum idx n))
5.110+ (ldb (byte 1 idx) n))
5.111+
5.112+;;; Bitfields
5.113+
5.114+;; see https://github.com/marcoheisig/bitfield
5.115+
5.116+;; A bitfield is a simple, efficient mechanism for storing multiple
5.117+;; discrete states into a single non-negative integer.
5.118+
5.119+(deftype bitfield ()
5.120+ "A bitfield is a non-negative integer that efficiently encodes
5.121+information about some booleans, enumerations, or small integers."
5.122+ 'unsigned-byte)
5.123+
5.124+;;; Bitfield Slots
5.125+(defgeneric bitfield-slot-name (bitfield-slot)
5.126+ (:documentation
5.127+ "Returns a symbol that is the name of the bitfield slot."))
5.128+
5.129+(defgeneric bitfield-slot-start (bitfield-slot)
5.130+ (:documentation
5.131+ "Returns the position of the first bit of this slot in the bitfield."))
5.132+
5.133+(defgeneric bitfield-slot-end (bitfield-slot)
5.134+ (:documentation
5.135+ "Returns the position right after the last bit of this slot in the bitfield."))
5.136+
5.137+(defgeneric bitfield-slot-size (bitfield-slot)
5.138+ (:documentation
5.139+ "Returns an unsigned byte that is the number of distinct states of the slot."))
5.140+
5.141+(defgeneric bitfield-slot-initform (bitfield-slot)
5.142+ (:documentation
5.143+ "Returns a form that produces the initial value for that slot."))
5.144+
5.145+(defgeneric bitfield-slot-pack (bitfield-slot value-form)
5.146+ (:documentation
5.147+ "Takes a form that produces a value and turns it into a form that produces
5.148+a non-negative integer representing that value."))
5.149+
5.150+(defgeneric bitfield-slot-unpack (bitfield-slot value-form)
5.151+ (:documentation
5.152+ "Take a form that produces a value that is encoded as a non-negative
5.153+integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that
5.154+produces the decoded value."))
5.155+
5.156+(defgeneric parse-atomic-bitfield-slot-specifier
5.157+ (specifier &key initform)
5.158+ (:documentation
5.159+ "Parses an atomic bitfield slot specifier, i.e., a bitfield slot
5.160+specifier that is not a list. Returns three values:
5.161+
5.162+1. A designator for a bitfield slot class.
5.163+
5.164+2. The size of the bitfield slot.
5.165+
5.166+3. A list of additional arguments that will be supplied to MAKE-INSTANCE
5.167+when creating the bitfield slot instance."))
5.168+
5.169+(defgeneric parse-compound-bitfield-slot-specifier
5.170+ (specifier arguments &key initform)
5.171+ (:documentation
5.172+ "Parses a compount bitfield slot specifier, i.e., a bitfield slot
5.173+specifier that is a list. The SPECIFIER is the CAR of that list and the
5.174+ARGUMENTS are the CDR of that list. Returns three values:
5.175+
5.176+1. A designator for a bitfield slot class.
5.177+
5.178+2. The size of the bitfield slot.
5.179+
5.180+3. A list of additional arguments that will be supplied to MAKE-INSTANCE
5.181+when creating the bitfield slot instance."))
5.182+
5.183+(defclass bitfield-slot ()
5.184+ ((%name :initarg :name :reader bitfield-slot-name)
5.185+ (%initform :initarg :initform :reader bitfield-slot-initform)
5.186+ (%start :initarg :start :reader bitfield-slot-start)
5.187+ (%end :initarg :end :reader bitfield-slot-end)
5.188+ (%size :initarg :size :reader bitfield-slot-size)))
5.189+
5.190+;;; Boolean Slots
5.191+(defclass bitfield-boolean-slot (bitfield-slot)
5.192+ ())
5.193+
5.194+(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form)
5.195+ `(if ,value-form 1 0))
5.196+
5.197+(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form)
5.198+ `(ecase ,value-form (0 nil) (1 t)))
5.199+
5.200+(defmethod parse-atomic-bitfield-slot-specifier
5.201+ ((specifier (eql 'boolean)) &key (initform 'nil))
5.202+ (values 'bitfield-boolean-slot
5.203+ 2
5.204+ `(:initform ,initform)))
5.205+
5.206+;;; Integer Slots
5.207+(defclass bitfield-integer-slot (bitfield-slot)
5.208+ ((%offset
5.209+ :type integer
5.210+ :initarg :offset
5.211+ :reader bitfield-integer-slot-offset)))
5.212+
5.213+(defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form)
5.214+ (let ((offset (bitfield-integer-slot-offset slot))
5.215+ (size (bitfield-slot-size slot)))
5.216+ `(the (integer 0 (,size))
5.217+ (- (the (integer ,offset (,(+ offset size))) ,value-form)
5.218+ ,offset))))
5.219+
5.220+(defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form)
5.221+ (let ((offset (bitfield-integer-slot-offset slot))
5.222+ (size (bitfield-slot-size slot)))
5.223+ `(the (integer ,offset (,(+ offset size)))
5.224+ (+ ,value-form ,offset))))
5.225+
5.226+(defmethod parse-atomic-bitfield-slot-specifier
5.227+ ((specifier (eql 'bit)) &key (initform '0))
5.228+ (values 'bitfield-unsigned-byte-slot
5.229+ 2
5.230+ `(:offset 0 :initform ,initform)))
5.231+
5.232+(defmethod parse-compound-bitfield-slot-specifier
5.233+ ((specifier (eql 'unsigned-byte)) arguments &key (initform '0))
5.234+ (destructuring-bind (bits) arguments
5.235+ (check-type bits unsigned-byte)
5.236+ (values 'bitfield-integer-slot
5.237+ (expt 2 bits)
5.238+ `(:offset 0 :initform ,initform))))
5.239+
5.240+(defmethod parse-compound-bitfield-slot-specifier
5.241+ ((specifier (eql 'signed-byte)) arguments &key (initform '0))
5.242+ (destructuring-bind (bits) arguments
5.243+ (check-type bits unsigned-byte)
5.244+ (values 'bitfield-integer-slot
5.245+ (expt 2 bits)
5.246+ `(:offset ,(- (expt 2 (1- bits))) :initform ,initform))))
5.247+
5.248+(defmethod parse-compound-bitfield-slot-specifier
5.249+ ((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p))
5.250+ (flet ((fail ()
5.251+ (error "Invalid integer bitfield slot specifier: ~S"
5.252+ `(integer ,@bounds))))
5.253+ (unless (typep bounds '(cons t (cons t null)))
5.254+ (fail))
5.255+ (destructuring-bind (lo hi) bounds
5.256+ (let* ((start (typecase lo
5.257+ (integer lo)
5.258+ ((cons integer null)
5.259+ (1+ (first lo)))
5.260+ (otherwise (fail))))
5.261+ (end (typecase hi
5.262+ (integer (1+ hi))
5.263+ ((cons integer null)
5.264+ (first hi))
5.265+ (otherwise (fail))))
5.266+ (size (- end start)))
5.267+ (unless (plusp size)
5.268+ (fail))
5.269+ (values 'bitfield-integer-slot
5.270+ size
5.271+ `(:offset ,start :initform ,(if initform-supplied-p initform start)))))))
5.272+
5.273+;;; Member Slots
5.274+(defclass bitfield-member-slot (bitfield-slot)
5.275+ ((%objects
5.276+ :type list
5.277+ :initarg :objects
5.278+ :reader bitfield-member-slot-objects)))
5.279+
5.280+(defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form)
5.281+ `(ecase ,value-form
5.282+ ,@(loop for key in (bitfield-member-slot-objects slot)
5.283+ for value from 0
5.284+ collect `((,key) ,value))))
5.285+
5.286+(defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form)
5.287+ `(ecase ,value-form
5.288+ ,@(loop for key from 0
5.289+ for value in (bitfield-member-slot-objects slot)
5.290+ collect `((,key) ',value))))
5.291+
5.292+(defmethod parse-compound-bitfield-slot-specifier
5.293+ ((specifier (eql 'member)) objects &key (initform `',(first objects)))
5.294+ (values 'bitfield-member-slot
5.295+ (length objects)
5.296+ `(:initform ,initform :objects ,objects)))
5.297+
5.298+;;; Parsing
5.299+;; The position right after the last slot that has been parsed so far.
5.300+(defvar *bitfield-position*)
5.301+
5.302+(defun parse-bitfield-slot (slot)
5.303+ (destructuring-bind (slot-name slot-specifier &rest rest) slot
5.304+ (check-type slot-name symbol)
5.305+ (multiple-value-bind (slot-class size args)
5.306+ (if (consp slot-specifier)
5.307+ (apply #'parse-compound-bitfield-slot-specifier
5.308+ (car slot-specifier)
5.309+ (cdr slot-specifier)
5.310+ rest)
5.311+ (apply #'parse-atomic-bitfield-slot-specifier
5.312+ slot-specifier
5.313+ rest))
5.314+ (apply #'make-instance slot-class
5.315+ :name slot-name
5.316+ :size size
5.317+ :start *bitfield-position*
5.318+ :end (incf *bitfield-position* (integer-length (1- size)))
5.319+ args))))
5.320+
5.321+(defmacro define-bitfield (name &body slots)
5.322+ "Defines an encoding of enumerable properties like booleans,
5.323+integers or finite sets as a single non-negative integer.
5.324+
5.325+For a supplied bitfield name NAME, and for some slot definitions of the
5.326+form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines
5.327+the following functions:
5.328+
5.329+1. A constructor named MAKE-{NAME}, that takes one keyword argument per
5.330+ SLOT-NAME, similar to the default constructor generated by DEFSTRUCT.
5.331+ It returns a bitfield whose entries have the values indicated by the
5.332+ keyword arguments, or the supplied initform.
5.333+
5.334+2. A clone operation named CLONE-{NAME}, that takes an existing bitfield
5.335+ and one keyword argument per SLOT-NAME. It returns a copy of the
5.336+ existing bitfield, but where each supplied keyword argument supersedes
5.337+ the value of the corresponding slot.
5.338+
5.339+3. A reader function named {NAME}-{SLOT-NAME} for each slot.
5.340+
5.341+In addition to these functions, NAME is defined as a suitable subtype of
5.342+UNSIGNED-BYTE.
5.343+
5.344+This macro supports boolean, integer, and member slots. It is also
5.345+possible to add new kinds of slots by defining new subclasses of
5.346+BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK,
5.347+BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or
5.348+PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER.
5.349+
5.350+ Example:
5.351+
5.352+ (define-bitfield examplebits
5.353+ (a boolean)
5.354+ (b (signed-byte 2))
5.355+ (c (unsigned-byte 3) :initform 1)
5.356+ (d (integer -100 100))
5.357+ (e (member foo bar baz)))
5.358+
5.359+ (defun examplebits-values (examplebits)
5.360+ (list
5.361+ (examplebits-a examplebits)
5.362+ (examplebits-b examplebits)
5.363+ (examplebits-c examplebits)
5.364+ (examplebits-d examplebits)
5.365+ (examplebits-e examplebits)))
5.366+
5.367+ (defparameter *default* (make-examplebits))
5.368+
5.369+ (examplebits-values *default*)
5.370+ ;; => (nil 0 1 -100 foo)
5.371+
5.372+ (defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz))
5.373+
5.374+ (examplebits-values *explicit*)
5.375+ ;; => (t -1 7 42 baz)
5.376+
5.377+ (defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar))
5.378+
5.379+ (examplebits-values *clone*)
5.380+ ;; => (nil -1 2 -12 bar)
5.381+"
5.382+ (let* ((*bitfield-position* 0)
5.383+ (package (symbol-package name))
5.384+ (constructor
5.385+ (intern (concatenate 'string "MAKE-" (symbol-name name)) package))
5.386+ (cloner
5.387+ (intern (concatenate 'string "CLONE-" (symbol-name name)) package))
5.388+ (reader-prefix
5.389+ (concatenate 'string ))
5.390+ (slots
5.391+ (mapcar #'parse-bitfield-slot slots))
5.392+ (reader-names
5.393+ (loop for slot in slots
5.394+ collect
5.395+ (intern (concatenate 'string (symbol-name name) "-" reader-prefix
5.396+ (symbol-name (bitfield-slot-name slot)))
5.397+ package))))
5.398+ `(progn
5.399+ (deftype ,name () '(unsigned-byte ,*bitfield-position*))
5.400+ ;; Define all slot readers.
5.401+ ,@(loop for slot in slots
5.402+ for reader-name in reader-names
5.403+ for start = (bitfield-slot-start slot)
5.404+ for end = (bitfield-slot-end slot)
5.405+ collect
5.406+ `(declaim (inline ,reader-name))
5.407+ collect
5.408+ `(defun ,reader-name (,name)
5.409+ (declare (,name ,name))
5.410+ ,(bitfield-slot-unpack
5.411+ slot
5.412+ `(ldb (byte ,(- end start) ,start) ,name))))
5.413+ ;; Define the cloner.
5.414+ (declaim (inline ,cloner))
5.415+ (defun ,cloner
5.416+ (,name &key ,@(loop for slot in slots
5.417+ for reader-name in reader-names
5.418+ collect
5.419+ `(,(bitfield-slot-name slot)
5.420+ (,reader-name ,name))))
5.421+ (declare (,name ,name))
5.422+ (logior
5.423+ ,@(loop for slot in slots
5.424+ collect
5.425+ `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
5.426+ ,(bitfield-slot-start slot)))))
5.427+ ;; Define the constructor.
5.428+ (declaim (inline ,constructor))
5.429+ (defun ,constructor
5.430+ (&key ,@(loop for slot in slots
5.431+ collect
5.432+ `(,(bitfield-slot-name slot)
5.433+ ,(bitfield-slot-initform slot))))
5.434+ (logior
5.435+ ,@(loop for slot in slots
5.436+ collect
5.437+ `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
5.438+ ,(bitfield-slot-start slot)))))
5.439+ ',name)))
5.440+
5.441+;;; From bit-smasher
5.442+(declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*))
5.443+(defvar *bit-map* #(#*0000
5.444+ #*0001
5.445+ #*0010
5.446+ #*0011
5.447+ #*0100
5.448+ #*0101
5.449+ #*0110
5.450+ #*0111
5.451+ #*1000
5.452+ #*1001
5.453+ #*1010
5.454+ #*1011
5.455+ #*1100
5.456+ #*1101
5.457+ #*1110
5.458+ #*1111))
5.459+
5.460+(deftype hex-char ()
5.461+ `(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
5.462+ #\a #\b #\c #\d #\e #\f
5.463+ #\A #\B #\C #\D #\E #\F))
5.464+
5.465+(declaim (ftype (function (hex-char) (integer 0 16)) hexchar->int)
5.466+ (inline hexchar->int))
5.467+(defun hexchar-to-int (char)
5.468+ "Return the bit vector associated with a hex-value character CHAR from *bit-map*."
5.469+ (declare (optimize (speed 2) (safety 0)))
5.470+ (cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0)))
5.471+ ((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10)))
5.472+ (t (- (char-code char) #.(- (char-code #\A) 10))
5.473+ ;; always return these results
5.474+ #+nil (char<= #\A char #\F))))
5.475+
5.476+;;; From Ironclad
5.477+(defun hex-string-to-octet-vector (string &aux (start 0) (end (length string)))
5.478+ "Parses a substring of STRING delimited by START and END of
5.479+hexadecimal digits into a byte array."
5.480+ (declare (type string string))
5.481+ (let* ((length
5.482+ (ash (- end start) -1)
5.483+ #+nil (/ (- end start) 2))
5.484+ (key (make-array length :element-type '(unsigned-byte 8))))
5.485+ (declare (type (simple-array (unsigned-byte 8)) key))
5.486+ (loop for i from 0
5.487+ for j from start below end by 2
5.488+ do (setf (aref key i)
5.489+ (+ (* (hexchar-to-int (char string j)) 16)
5.490+ (hexchar-to-int (char string (1+ j)))))
5.491+ finally (return key))))
5.492+
5.493+(defun octet-vector-to-hex-string (vector)
5.494+ "Return a string containing the hexadecimal representation of the
5.495+subsequence of VECTOR between START and END. ELEMENT-TYPE controls
5.496+the element-type of the returned string."
5.497+ (declare (type (vector (unsigned-byte 8)) vector))
5.498+ (let* ((length (length vector))
5.499+ (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string)))
5.500+ (loop with string = (make-string (* length 2) :element-type 'base-char)
5.501+ for i from 0 below length
5.502+ for j from 0 by 2
5.503+ do (let ((byte (aref vector i)))
5.504+ (declare (optimize (safety 0)))
5.505+ (setf (aref string j)
5.506+ (aref hexdigits (ldb (byte 4 4) byte))
5.507+ (aref string (1+ j))
5.508+ (aref hexdigits (ldb (byte 4 0) byte))))
5.509+ finally (return string))))
5.510+
5.511+(defun octets-to-integer (octet-vec &optional (end (length octet-vec)))
5.512+ (declare (type (simple-array (unsigned-byte 8)) octet-vec))
5.513+ (do ((j 0 (1+ j))
5.514+ (sum 0))
5.515+ ((>= j end) sum)
5.516+ (setf sum (+ (aref octet-vec j) (ash sum 8)))))
5.517+
5.518+(defun integer-to-octets (bignum &optional (n-bits (integer-length bignum)))
5.519+ (let* ((n-bytes (ceiling n-bits 8))
5.520+ (octet-vec (make-array n-bytes :element-type '(unsigned-byte 8))))
5.521+ (declare (type (simple-array (unsigned-byte 8)) octet-vec))
5.522+ (loop for i from (1- n-bytes) downto 0
5.523+ for index from 0
5.524+ do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum))
5.525+ finally (return octet-vec))))
6.1--- a/lisp/std/bits.lisp Sun Apr 21 22:38:49 2024 -0400
6.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
6.3@@ -1,522 +0,0 @@
6.4-;;; bits.lisp --- Bit manipulation
6.5-
6.6-;;; Commentary:
6.7-
6.8-;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html
6.9-
6.10-;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html
6.11-
6.12-;;; Code:
6.13-(in-package :std)
6.14-
6.15-;;; Types
6.16-;; Bytes aren't necessarily 8 bits wide in Lisp. OCTET is always 8
6.17-;; bits.
6.18-(deftype octet () '(unsigned-byte 8))
6.19-(deftype octet-vector (&optional length)
6.20- `(simple-array octet (,length)))
6.21-
6.22-;;; Bits
6.23-(defun make-bits (length &rest args)
6.24- (apply #'make-array length (nconc (list :element-type 'bit) args)))
6.25-
6.26-;; https://graphics.stanford.edu/~seander/bithacks.html
6.27-;; http://www.azillionmonkeys.com/qed/asmexample.html
6.28-(defun haipart (n count)
6.29- (declare (fixnum n count))
6.30- (let ((x (abs n)))
6.31- (if (minusp count)
6.32- (ldb (byte (- count) 0) x)
6.33- (ldb (byte count (max 0 (- (integer-length x) count)))
6.34- x))))
6.35-
6.36-;; minusp = 38 bytes
6.37-
6.38-;; 29 bytes
6.39-(defun sign-bit (n)
6.40- "compute the sign bit of a fixnum. If N < 0 return -1 else return 0."
6.41- (declare (fixnum n))
6.42- (ash n (- 0 (integer-length n))))
6.43-
6.44-;; 51 bytes (speed 3)
6.45-;; 67 bytes (speed 1)
6.46-(defun different-signs-p (x y)
6.47- "Return non-nil iff x and y have opposite signs."
6.48- (declare (fixnum x y) (optimize (speed 1)))
6.49- (< (expt x y) 0))
6.50-
6.51-;; TODO 2024-02-23:
6.52-(defun mortify-bits (x y)
6.53- "Interleave the bits of two numbers (Mortan numbers)."
6.54- (declare (fixnum x y)
6.55- (ignore x y))
6.56- ;; (loop for i across (integer-length)
6.57- ;; with z = 0
6.58- ;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1);
6.59- ;; do ()
6.60- ;; return z)
6.61- )
6.62-
6.63-(defun int-list-bits (n)
6.64- (declare (fixnum n))
6.65- (let ((bits '()))
6.66- (dotimes (position (integer-length n) bits)
6.67- (push (ldb (byte 1 position) n) bits))))
6.68-
6.69-(defun int-bit-vector (n)
6.70- (declare (fixnum n))
6.71- (let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t)))
6.72- (dotimes (position (integer-length n) bits)
6.73- (vector-push-extend (ldb (byte 1 position) n) bits))))
6.74-
6.75-(defun aref-bit (octets idx)
6.76- (declare (octet-vector octets) (fixnum idx))
6.77- (multiple-value-bind (octet-idx bit-idx)
6.78- (truncate idx 8)
6.79- (ldb (byte 1 bit-idx)
6.80- (aref octets octet-idx))))
6.81-
6.82-(defun make-bit-vector (size &optional (fill 0))
6.83- "Make a BIT-VECTOR with SIZE and initial-element FILL which must be a
6.84-BIT 0|1. Note that this representation is not as useful as you might
6.85-think - bit-vectors don't have a direct mapping to integers/fixnums --
6.86-they are vectors (AKA arrays) first, and bits second. Attempting to
6.87-perform bitwise-ops ends up being very inefficient so whenever
6.88-possible, stick with fixnums and use LOG* functions."
6.89- (declare (bit fill))
6.90- (make-array size :initial-element fill :adjustable nil :element-type 'bit))
6.91-
6.92-;; simple setter/getter for integer bits
6.93-(define-setf-expander logbit (index place &environment env)
6.94- (multiple-value-bind (temps vals stores store-form access-form)
6.95- (get-setf-expansion place env)
6.96- (let ((i (gensym))
6.97- (store (gensym))
6.98- (stemp (first stores)))
6.99- (values `(,i ,@temps)
6.100- `(,index ,@vals)
6.101- `(,store)
6.102- `(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form))
6.103- ,@(cdr stores))
6.104- ,store-form
6.105- ,store)
6.106- `(logbit ,i ,access-form)))))
6.107-
6.108-(defun logbit (idx n)
6.109- (declare (fixnum idx n))
6.110- (ldb (byte 1 idx) n))
6.111-
6.112-;;; Bitfields
6.113-
6.114-;; see https://github.com/marcoheisig/bitfield
6.115-
6.116-;; A bitfield is a simple, efficient mechanism for storing multiple
6.117-;; discrete states into a single non-negative integer.
6.118-
6.119-(deftype bitfield ()
6.120- "A bitfield is a non-negative integer that efficiently encodes
6.121-information about some booleans, enumerations, or small integers."
6.122- 'unsigned-byte)
6.123-
6.124-;;; Bitfield Slots
6.125-(defgeneric bitfield-slot-name (bitfield-slot)
6.126- (:documentation
6.127- "Returns a symbol that is the name of the bitfield slot."))
6.128-
6.129-(defgeneric bitfield-slot-start (bitfield-slot)
6.130- (:documentation
6.131- "Returns the position of the first bit of this slot in the bitfield."))
6.132-
6.133-(defgeneric bitfield-slot-end (bitfield-slot)
6.134- (:documentation
6.135- "Returns the position right after the last bit of this slot in the bitfield."))
6.136-
6.137-(defgeneric bitfield-slot-size (bitfield-slot)
6.138- (:documentation
6.139- "Returns an unsigned byte that is the number of distinct states of the slot."))
6.140-
6.141-(defgeneric bitfield-slot-initform (bitfield-slot)
6.142- (:documentation
6.143- "Returns a form that produces the initial value for that slot."))
6.144-
6.145-(defgeneric bitfield-slot-pack (bitfield-slot value-form)
6.146- (:documentation
6.147- "Takes a form that produces a value and turns it into a form that produces
6.148-a non-negative integer representing that value."))
6.149-
6.150-(defgeneric bitfield-slot-unpack (bitfield-slot value-form)
6.151- (:documentation
6.152- "Take a form that produces a value that is encoded as a non-negative
6.153-integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that
6.154-produces the decoded value."))
6.155-
6.156-(defgeneric parse-atomic-bitfield-slot-specifier
6.157- (specifier &key initform)
6.158- (:documentation
6.159- "Parses an atomic bitfield slot specifier, i.e., a bitfield slot
6.160-specifier that is not a list. Returns three values:
6.161-
6.162-1. A designator for a bitfield slot class.
6.163-
6.164-2. The size of the bitfield slot.
6.165-
6.166-3. A list of additional arguments that will be supplied to MAKE-INSTANCE
6.167-when creating the bitfield slot instance."))
6.168-
6.169-(defgeneric parse-compound-bitfield-slot-specifier
6.170- (specifier arguments &key initform)
6.171- (:documentation
6.172- "Parses a compount bitfield slot specifier, i.e., a bitfield slot
6.173-specifier that is a list. The SPECIFIER is the CAR of that list and the
6.174-ARGUMENTS are the CDR of that list. Returns three values:
6.175-
6.176-1. A designator for a bitfield slot class.
6.177-
6.178-2. The size of the bitfield slot.
6.179-
6.180-3. A list of additional arguments that will be supplied to MAKE-INSTANCE
6.181-when creating the bitfield slot instance."))
6.182-
6.183-(defclass bitfield-slot ()
6.184- ((%name :initarg :name :reader bitfield-slot-name)
6.185- (%initform :initarg :initform :reader bitfield-slot-initform)
6.186- (%start :initarg :start :reader bitfield-slot-start)
6.187- (%end :initarg :end :reader bitfield-slot-end)
6.188- (%size :initarg :size :reader bitfield-slot-size)))
6.189-
6.190-;;; Boolean Slots
6.191-(defclass bitfield-boolean-slot (bitfield-slot)
6.192- ())
6.193-
6.194-(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form)
6.195- `(if ,value-form 1 0))
6.196-
6.197-(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form)
6.198- `(ecase ,value-form (0 nil) (1 t)))
6.199-
6.200-(defmethod parse-atomic-bitfield-slot-specifier
6.201- ((specifier (eql 'boolean)) &key (initform 'nil))
6.202- (values 'bitfield-boolean-slot
6.203- 2
6.204- `(:initform ,initform)))
6.205-
6.206-;;; Integer Slots
6.207-(defclass bitfield-integer-slot (bitfield-slot)
6.208- ((%offset
6.209- :type integer
6.210- :initarg :offset
6.211- :reader bitfield-integer-slot-offset)))
6.212-
6.213-(defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form)
6.214- (let ((offset (bitfield-integer-slot-offset slot))
6.215- (size (bitfield-slot-size slot)))
6.216- `(the (integer 0 (,size))
6.217- (- (the (integer ,offset (,(+ offset size))) ,value-form)
6.218- ,offset))))
6.219-
6.220-(defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form)
6.221- (let ((offset (bitfield-integer-slot-offset slot))
6.222- (size (bitfield-slot-size slot)))
6.223- `(the (integer ,offset (,(+ offset size)))
6.224- (+ ,value-form ,offset))))
6.225-
6.226-(defmethod parse-atomic-bitfield-slot-specifier
6.227- ((specifier (eql 'bit)) &key (initform '0))
6.228- (values 'bitfield-unsigned-byte-slot
6.229- 2
6.230- `(:offset 0 :initform ,initform)))
6.231-
6.232-(defmethod parse-compound-bitfield-slot-specifier
6.233- ((specifier (eql 'unsigned-byte)) arguments &key (initform '0))
6.234- (destructuring-bind (bits) arguments
6.235- (check-type bits unsigned-byte)
6.236- (values 'bitfield-integer-slot
6.237- (expt 2 bits)
6.238- `(:offset 0 :initform ,initform))))
6.239-
6.240-(defmethod parse-compound-bitfield-slot-specifier
6.241- ((specifier (eql 'signed-byte)) arguments &key (initform '0))
6.242- (destructuring-bind (bits) arguments
6.243- (check-type bits unsigned-byte)
6.244- (values 'bitfield-integer-slot
6.245- (expt 2 bits)
6.246- `(:offset ,(- (expt 2 (1- bits))) :initform ,initform))))
6.247-
6.248-(defmethod parse-compound-bitfield-slot-specifier
6.249- ((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p))
6.250- (flet ((fail ()
6.251- (error "Invalid integer bitfield slot specifier: ~S"
6.252- `(integer ,@bounds))))
6.253- (unless (typep bounds '(cons t (cons t null)))
6.254- (fail))
6.255- (destructuring-bind (lo hi) bounds
6.256- (let* ((start (typecase lo
6.257- (integer lo)
6.258- ((cons integer null)
6.259- (1+ (first lo)))
6.260- (otherwise (fail))))
6.261- (end (typecase hi
6.262- (integer (1+ hi))
6.263- ((cons integer null)
6.264- (first hi))
6.265- (otherwise (fail))))
6.266- (size (- end start)))
6.267- (unless (plusp size)
6.268- (fail))
6.269- (values 'bitfield-integer-slot
6.270- size
6.271- `(:offset ,start :initform ,(if initform-supplied-p initform start)))))))
6.272-
6.273-;;; Member Slots
6.274-(defclass bitfield-member-slot (bitfield-slot)
6.275- ((%objects
6.276- :type list
6.277- :initarg :objects
6.278- :reader bitfield-member-slot-objects)))
6.279-
6.280-(defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form)
6.281- `(ecase ,value-form
6.282- ,@(loop for key in (bitfield-member-slot-objects slot)
6.283- for value from 0
6.284- collect `((,key) ,value))))
6.285-
6.286-(defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form)
6.287- `(ecase ,value-form
6.288- ,@(loop for key from 0
6.289- for value in (bitfield-member-slot-objects slot)
6.290- collect `((,key) ',value))))
6.291-
6.292-(defmethod parse-compound-bitfield-slot-specifier
6.293- ((specifier (eql 'member)) objects &key (initform `',(first objects)))
6.294- (values 'bitfield-member-slot
6.295- (length objects)
6.296- `(:initform ,initform :objects ,objects)))
6.297-
6.298-;;; Parsing
6.299-;; The position right after the last slot that has been parsed so far.
6.300-(defvar *bitfield-position*)
6.301-
6.302-(defun parse-bitfield-slot (slot)
6.303- (destructuring-bind (slot-name slot-specifier &rest rest) slot
6.304- (check-type slot-name symbol)
6.305- (multiple-value-bind (slot-class size args)
6.306- (if (consp slot-specifier)
6.307- (apply #'parse-compound-bitfield-slot-specifier
6.308- (car slot-specifier)
6.309- (cdr slot-specifier)
6.310- rest)
6.311- (apply #'parse-atomic-bitfield-slot-specifier
6.312- slot-specifier
6.313- rest))
6.314- (apply #'make-instance slot-class
6.315- :name slot-name
6.316- :size size
6.317- :start *bitfield-position*
6.318- :end (incf *bitfield-position* (integer-length (1- size)))
6.319- args))))
6.320-
6.321-(defmacro define-bitfield (name &body slots)
6.322- "Defines an encoding of enumerable properties like booleans,
6.323-integers or finite sets as a single non-negative integer.
6.324-
6.325-For a supplied bitfield name NAME, and for some slot definitions of the
6.326-form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines
6.327-the following functions:
6.328-
6.329-1. A constructor named MAKE-{NAME}, that takes one keyword argument per
6.330- SLOT-NAME, similar to the default constructor generated by DEFSTRUCT.
6.331- It returns a bitfield whose entries have the values indicated by the
6.332- keyword arguments, or the supplied initform.
6.333-
6.334-2. A clone operation named CLONE-{NAME}, that takes an existing bitfield
6.335- and one keyword argument per SLOT-NAME. It returns a copy of the
6.336- existing bitfield, but where each supplied keyword argument supersedes
6.337- the value of the corresponding slot.
6.338-
6.339-3. A reader function named {NAME}-{SLOT-NAME} for each slot.
6.340-
6.341-In addition to these functions, NAME is defined as a suitable subtype of
6.342-UNSIGNED-BYTE.
6.343-
6.344-This macro supports boolean, integer, and member slots. It is also
6.345-possible to add new kinds of slots by defining new subclasses of
6.346-BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK,
6.347-BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or
6.348-PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER.
6.349-
6.350- Example:
6.351-
6.352- (define-bitfield examplebits
6.353- (a boolean)
6.354- (b (signed-byte 2))
6.355- (c (unsigned-byte 3) :initform 1)
6.356- (d (integer -100 100))
6.357- (e (member foo bar baz)))
6.358-
6.359- (defun examplebits-values (examplebits)
6.360- (list
6.361- (examplebits-a examplebits)
6.362- (examplebits-b examplebits)
6.363- (examplebits-c examplebits)
6.364- (examplebits-d examplebits)
6.365- (examplebits-e examplebits)))
6.366-
6.367- (defparameter *default* (make-examplebits))
6.368-
6.369- (examplebits-values *default*)
6.370- ;; => (nil 0 1 -100 foo)
6.371-
6.372- (defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz))
6.373-
6.374- (examplebits-values *explicit*)
6.375- ;; => (t -1 7 42 baz)
6.376-
6.377- (defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar))
6.378-
6.379- (examplebits-values *clone*)
6.380- ;; => (nil -1 2 -12 bar)
6.381-"
6.382- (let* ((*bitfield-position* 0)
6.383- (package (symbol-package name))
6.384- (constructor
6.385- (intern (concatenate 'string "MAKE-" (symbol-name name)) package))
6.386- (cloner
6.387- (intern (concatenate 'string "CLONE-" (symbol-name name)) package))
6.388- (reader-prefix
6.389- (concatenate 'string ))
6.390- (slots
6.391- (mapcar #'parse-bitfield-slot slots))
6.392- (reader-names
6.393- (loop for slot in slots
6.394- collect
6.395- (intern (concatenate 'string (symbol-name name) "-" reader-prefix
6.396- (symbol-name (bitfield-slot-name slot)))
6.397- package))))
6.398- `(progn
6.399- (deftype ,name () '(unsigned-byte ,*bitfield-position*))
6.400- ;; Define all slot readers.
6.401- ,@(loop for slot in slots
6.402- for reader-name in reader-names
6.403- for start = (bitfield-slot-start slot)
6.404- for end = (bitfield-slot-end slot)
6.405- collect
6.406- `(declaim (inline ,reader-name))
6.407- collect
6.408- `(defun ,reader-name (,name)
6.409- (declare (,name ,name))
6.410- ,(bitfield-slot-unpack
6.411- slot
6.412- `(ldb (byte ,(- end start) ,start) ,name))))
6.413- ;; Define the cloner.
6.414- (declaim (inline ,cloner))
6.415- (defun ,cloner
6.416- (,name &key ,@(loop for slot in slots
6.417- for reader-name in reader-names
6.418- collect
6.419- `(,(bitfield-slot-name slot)
6.420- (,reader-name ,name))))
6.421- (declare (,name ,name))
6.422- (logior
6.423- ,@(loop for slot in slots
6.424- collect
6.425- `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
6.426- ,(bitfield-slot-start slot)))))
6.427- ;; Define the constructor.
6.428- (declaim (inline ,constructor))
6.429- (defun ,constructor
6.430- (&key ,@(loop for slot in slots
6.431- collect
6.432- `(,(bitfield-slot-name slot)
6.433- ,(bitfield-slot-initform slot))))
6.434- (logior
6.435- ,@(loop for slot in slots
6.436- collect
6.437- `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot))
6.438- ,(bitfield-slot-start slot)))))
6.439- ',name)))
6.440-
6.441-;;; From bit-smasher
6.442-(declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*))
6.443-(defvar *bit-map* #(#*0000
6.444- #*0001
6.445- #*0010
6.446- #*0011
6.447- #*0100
6.448- #*0101
6.449- #*0110
6.450- #*0111
6.451- #*1000
6.452- #*1001
6.453- #*1010
6.454- #*1011
6.455- #*1100
6.456- #*1101
6.457- #*1110
6.458- #*1111))
6.459-
6.460-(deftype hex-char ()
6.461- `(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
6.462- #\a #\b #\c #\d #\e #\f
6.463- #\A #\B #\C #\D #\E #\F))
6.464-
6.465-(declaim (ftype (function (hex-char) (integer 0 16)) hexchar->int)
6.466- (inline hexchar->int))
6.467-(defun hexchar-to-int (char)
6.468- "Return the bit vector associated with a hex-value character CHAR from *bit-map*."
6.469- (declare (optimize (speed 2) (safety 0)))
6.470- (cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0)))
6.471- ((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10)))
6.472- (t (- (char-code char) #.(- (char-code #\A) 10))
6.473- ;; always return these results
6.474- #+nil (char<= #\A char #\F))))
6.475-
6.476-;;; From Ironclad
6.477-(defun hex-string-to-octet-vector (string &aux (start 0) (end (length string)))
6.478- "Parses a substring of STRING delimited by START and END of
6.479-hexadecimal digits into a byte array."
6.480- (declare (type string string))
6.481- (let* ((length
6.482- (ash (- end start) -1)
6.483- #+nil (/ (- end start) 2))
6.484- (key (make-array length :element-type '(unsigned-byte 8))))
6.485- (declare (type (simple-array (unsigned-byte 8)) key))
6.486- (loop for i from 0
6.487- for j from start below end by 2
6.488- do (setf (aref key i)
6.489- (+ (* (hexchar-to-int (char string j)) 16)
6.490- (hexchar-to-int (char string (1+ j)))))
6.491- finally (return key))))
6.492-
6.493-(defun octet-vector-to-hex-string (vector)
6.494- "Return a string containing the hexadecimal representation of the
6.495-subsequence of VECTOR between START and END. ELEMENT-TYPE controls
6.496-the element-type of the returned string."
6.497- (declare (type (vector (unsigned-byte 8)) vector))
6.498- (let* ((length (length vector))
6.499- (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string)))
6.500- (loop with string = (make-string (* length 2) :element-type 'base-char)
6.501- for i from 0 below length
6.502- for j from 0 by 2
6.503- do (let ((byte (aref vector i)))
6.504- (declare (optimize (safety 0)))
6.505- (setf (aref string j)
6.506- (aref hexdigits (ldb (byte 4 4) byte))
6.507- (aref string (1+ j))
6.508- (aref hexdigits (ldb (byte 4 0) byte))))
6.509- finally (return string))))
6.510-
6.511-(defun octets-to-integer (octet-vec &optional (end (length octet-vec)))
6.512- (declare (type (simple-array (unsigned-byte 8)) octet-vec))
6.513- (do ((j 0 (1+ j))
6.514- (sum 0))
6.515- ((>= j end) sum)
6.516- (setf sum (+ (aref octet-vec j) (ash sum 8)))))
6.517-
6.518-(defun integer-to-octets (bignum &optional (n-bits (integer-length bignum)))
6.519- (let* ((n-bytes (ceiling n-bits 8))
6.520- (octet-vec (make-array n-bytes :element-type '(unsigned-byte 8))))
6.521- (declare (type (simple-array (unsigned-byte 8)) octet-vec))
6.522- (loop for i from (1- n-bytes) downto 0
6.523- for index from 0
6.524- do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum))
6.525- finally (return octet-vec))))
7.1--- a/lisp/std/defpkg.lisp Sun Apr 21 22:38:49 2024 -0400
7.2+++ b/lisp/std/defpkg.lisp Mon Apr 22 23:14:47 2024 -0400
7.3@@ -5,7 +5,7 @@
7.4 ;;
7.5
7.6 ;;; Code:
7.7-(in-package :std)
7.8+(in-package :std/defpkg)
7.9
7.10 (eval-when (:load-toplevel :compile-toplevel :execute)
7.11 (defun find-package* (package-designator &optional (error t))
8.1--- a/lisp/std/err.lisp Sun Apr 21 22:38:49 2024 -0400
8.2+++ b/lisp/std/err.lisp Mon Apr 22 23:14:47 2024 -0400
8.3@@ -1,7 +1,7 @@
8.4 ;;; err.lisp --- Conditions and other exception handlers
8.5
8.6 ;;; Code:
8.7-(in-package :std)
8.8+(in-package :std/err)
8.9
8.10 (defvar *std-error-message* "An error occured")
8.11
9.1--- a/lisp/std/file.lisp Sun Apr 21 22:38:49 2024 -0400
9.2+++ b/lisp/std/file.lisp Mon Apr 22 23:14:47 2024 -0400
9.3@@ -3,7 +3,22 @@
9.4 ;;
9.5
9.6 ;;; Code:
9.7-(in-package :std)
9.8+(in-package :std/file)
9.9+
9.10+;;; Sexp utils
9.11+;; (reexport-from :uiop :include '(read-file-form read-file-forms slurp-stream-forms))
9.12+
9.13+(defun tmpfile (size)
9.14+ "Create an anonymous temporary file of the given size. Returns a file descriptor."
9.15+ (let (done fd pathname)
9.16+ (unwind-protect
9.17+ (progn
9.18+ (setf (values fd pathname) (sb-posix:mkstemp "/dev/shm/tmp.XXXXXXXX"))
9.19+ (sb-posix:unlink pathname)
9.20+ (sb-posix:ftruncate fd size)
9.21+ (setf done t))
9.22+ (when (and fd (not done)) (sb-posix:close fd)))
9.23+ fd))
9.24
9.25 (declaim (inline octet-vector=/unsafe))
9.26 (defun octet-vector=/unsafe (v1 v2 start1 end1 start2 end2)
10.1--- a/lisp/std/fmt.lisp Sun Apr 21 22:38:49 2024 -0400
10.2+++ b/lisp/std/fmt.lisp Mon Apr 22 23:14:47 2024 -0400
10.3@@ -1,7 +1,7 @@
10.4 ;;; std/fmt.lisp --- printer and format utils
10.5
10.6 ;;; Code:
10.7-(in-package :std)
10.8+(in-package :std/fmt)
10.9
10.10 (defun iprintln (x &optional (n 2) stream)
10.11 (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream))
11.1--- a/lisp/std/fu.lisp Sun Apr 21 22:38:49 2024 -0400
11.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
11.3@@ -1,872 +0,0 @@
11.4-;;; fu.lisp --- Function utilities
11.5-
11.6-;;
11.7-
11.8-;;; Code:
11.9-(in-package :std)
11.10-
11.11-(in-readtable :std)
11.12-
11.13-(defmacro! sortf (comparator &rest places)
11.14- (if places
11.15- `(tagbody
11.16- ,@(mapcar
11.17- #`(let ((,g!a #1=,(nth (car a1) places))
11.18- (,g!b #2=,(nth (cadr a1) places)))
11.19- (if (,comparator ,g!b ,g!a)
11.20- (setf #1# ,g!b
11.21- #2# ,g!a)))
11.22- (build-batcher-sn (length places))))))
11.23-
11.24-#+cl-ppcre
11.25-(defun dollar-symbol-p (s)
11.26- (and (symbolp s)
11.27- (> (length (symbol-name s)) 1)
11.28- (string= (symbol-name s)
11.29- "$"
11.30- :start1 0
11.31- :end1 1)
11.32- (ignore-errors (parse-integer (subseq (symbol-name s) 1)))))
11.33-
11.34-
11.35-#+cl-ppcre
11.36-(defmacro! if-match ((match-regex str) then &optional else)
11.37- (let* ((dollars (remove-duplicates
11.38- (remove-if-not #'dollar-symbol-p
11.39- (flatten then))))
11.40- (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>))
11.41- 0)))
11.42- `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str)
11.43- (declare (ignorable ,g!matches ,g!captures))
11.44- (let ((,g!captures-len (length ,g!captures)))
11.45- (declare (ignorable ,g!captures-len))
11.46- (symbol-macrolet ,(mapcar #`(,(symb "$" a1)
11.47- (if (< ,g!captures-len ,a1)
11.48- (error "Too few matchs: ~a unbound." ,(mkstr "$" a1))
11.49- (aref ,g!captures ,(1- a1))))
11.50- (loop for i from 1 to top collect i))
11.51- (if ,g!matches
11.52- ,then
11.53- ,else))))))
11.54-
11.55-#+cl-ppcre
11.56-(defmacro when-match ((match-regex str) &body forms)
11.57- `(if-match (,match-regex ,str)
11.58- (progn ,@forms)))
11.59-
11.60-(defmacro once-only (specs &body forms)
11.61- "Constructs code whose primary goal is to help automate the handling of
11.62-multiple evaluation within macros. Multiple evaluation is handled by introducing
11.63-intermediate variables, in order to reuse the result of an expression.
11.64-
11.65-The returned value is a list of the form
11.66-
11.67- (let ((<gensym-1> <expr-1>)
11.68- ...
11.69- (<gensym-n> <expr-n>))
11.70- <res>)
11.71-
11.72-where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
11.73-to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
11.74-evaluating the implicit progn FORMS within a special context determined by
11.75-SPECS. RES should make use of (reference) the intermediate variables.
11.76-
11.77-Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
11.78-Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
11.79-
11.80-Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
11.81-
11.82-- INITFORM is an expression evaluated to produce EXPR-i
11.83-
11.84-- SYMBOL is the name of the variable that will be bound around FORMS to the
11.85- corresponding gensym GENSYM-i, in order for FORMS to generate RES that
11.86- references the intermediate variable
11.87-
11.88-The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
11.89-all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
11.90-
11.91-Example:
11.92-
11.93- The following expression
11.94-
11.95- (let ((x '(incf y)))
11.96- (once-only (x)
11.97- `(cons ,x ,x)))
11.98-
11.99- ;;; =>
11.100- ;;; (let ((#1=#:X123 (incf y)))
11.101- ;;; (cons #1# #1#))
11.102-
11.103- could be used within a macro to avoid multiple evaluation like so
11.104-
11.105- (defmacro cons1 (x)
11.106- (once-only (x)
11.107- `(cons ,x ,x)))
11.108-
11.109- (let ((y 0))
11.110- (cons1 (incf y)))
11.111-
11.112- ;;; => (1 . 1)
11.113-
11.114-Example:
11.115-
11.116- The following expression demonstrates the usage of the INITFORM field
11.117-
11.118- (let ((expr '(incf y)))
11.119- (once-only ((var `(1+ ,expr)))
11.120- `(list ',expr ,var ,var)))
11.121-
11.122- ;;; =>
11.123- ;;; (let ((#1=#:VAR123 (1+ (incf y))))
11.124- ;;; (list '(incf y) #1# #1))
11.125-
11.126- which could be used like so
11.127-
11.128- (defmacro print-succ-twice (expr)
11.129- (once-only ((var `(1+ ,expr)))
11.130- `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
11.131-
11.132- (let ((y 10))
11.133- (print-succ-twice (incf y)))
11.134-
11.135- ;;; >>
11.136- ;;; Expr: (INCF Y), Once: 12, Twice: 12"
11.137- (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
11.138- (names-and-forms (mapcar (lambda (spec)
11.139- (etypecase spec
11.140- (list
11.141- (destructuring-bind (name form) spec
11.142- (cons name form)))
11.143- (symbol
11.144- (cons spec spec))))
11.145- specs)))
11.146- ;; bind in user-macro
11.147- `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
11.148- gensyms names-and-forms)
11.149- ;; bind in final expansion
11.150- `(let (,,@(mapcar (lambda (g n)
11.151- ``(,,g ,,(cdr n)))
11.152- gensyms names-and-forms))
11.153- ;; bind in user-macro
11.154- ,(let ,(mapcar (lambda (n g) (list (car n) g))
11.155- names-and-forms gensyms)
11.156- ,@forms)))))
11.157-
11.158-;;;; DESTRUCTURING-*CASE
11.159-
11.160-(defun expand-destructuring-case (key clauses case)
11.161- (once-only (key)
11.162- `(if (typep ,key 'cons)
11.163- (,case (car ,key)
11.164- ,@(mapcar (lambda (clause)
11.165- (destructuring-bind ((keys . lambda-list) &body body) clause
11.166- `(,keys
11.167- (destructuring-bind ,lambda-list (cdr ,key)
11.168- ,@body))))
11.169- clauses))
11.170- (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
11.171-
11.172-(defmacro destructuring-case (keyform &body clauses)
11.173- "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
11.174-KEYFORM must evaluate to a CONS.
11.175-
11.176-Clauses are of the form:
11.177-
11.178- ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
11.179-
11.180-The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
11.181-is selected, and FORMs are then executed with CDR of KEY is destructured and
11.182-bound by the DESTRUCTURING-LAMBDA-LIST.
11.183-
11.184-Example:
11.185-
11.186- (defun dcase (x)
11.187- (destructuring-case x
11.188- ((:foo a b)
11.189- (format nil \"foo: ~S, ~S\" a b))
11.190- ((:bar &key a b)
11.191- (format nil \"bar: ~S, ~S\" a b))
11.192- (((:alt1 :alt2) a)
11.193- (format nil \"alt: ~S\" a))
11.194- ((t &rest rest)
11.195- (format nil \"unknown: ~S\" rest))))
11.196-
11.197- (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
11.198- (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
11.199- (dcase (list :alt1 1)) ; => \"alt: 1\"
11.200- (dcase (list :alt2 2)) ; => \"alt: 2\"
11.201- (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
11.202-
11.203- (defun decase (x)
11.204- (destructuring-case x
11.205- ((:foo a b)
11.206- (format nil \"foo: ~S, ~S\" a b))
11.207- ((:bar &key a b)
11.208- (format nil \"bar: ~S, ~S\" a b))
11.209- (((:alt1 :alt2) a)
11.210- (format nil \"alt: ~S\" a))))
11.211-
11.212- (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
11.213- (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
11.214- (decase (list :alt1 1)) ; => \"alt: 1\"
11.215- (decase (list :alt2 2)) ; => \"alt: 2\"
11.216- (decase (list :quux 1 2 3)) ; =| error
11.217-"
11.218- (expand-destructuring-case keyform clauses 'case))
11.219-
11.220-(defmacro destructuring-ccase (keyform &body clauses)
11.221- (expand-destructuring-case keyform clauses 'ccase))
11.222-
11.223-(defmacro destructuring-ecase (keyform &body clauses)
11.224- (expand-destructuring-case keyform clauses 'ecase))
11.225-
11.226-(dolist (name '(destructuring-ccase destructuring-ecase))
11.227- (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
11.228-
11.229-;;; *-let --- control-flow let-binding macros
11.230-;; based on https://stevelosh.com/blog/2018/07/fun-with-macros-if-let/
11.231-
11.232-(defmacro when-let (bindings &body body)
11.233- "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.
11.234-
11.235- This macro combines `when` and `let`. It takes a list of bindings and
11.236- binds them like `let` before executing `body`, but if any binding's value
11.237- evaluates to `nil` the process stops and `nil` is immediately returned.
11.238-
11.239- Examples:
11.240-
11.241- (when-let ((a (progn (print :a) 1))
11.242- (b (progn (print :b) 2))
11.243- (list a b))
11.244- ; =>
11.245- :A
11.246- :B
11.247- (1 2)
11.248-
11.249- (when-let ((a (progn (print :a) nil))
11.250- (b (progn (print :b) 2)))
11.251- (list a b))
11.252- ; =>
11.253- :A
11.254- NIL
11.255-
11.256- "
11.257- (with-gensyms (block)
11.258- `(block ,block
11.259- (let ,(loop :for (symbol value) :in bindings
11.260- :collect `(,symbol (or ,value
11.261- (return-from ,block nil))))
11.262- ,@body))))
11.263-
11.264-(defmacro when-let* (bindings &body body)
11.265- "Bind `bindings` serially and execute `body`, short-circuiting on `nil`.
11.266-
11.267- This macro combines `when` and `let*`. It takes a list of bindings
11.268- and binds them like `let*` before executing `body`, but if any
11.269- binding's value evaluates to `nil` the process stops and `nil` is
11.270- immediately returned.
11.271-
11.272- Examples:
11.273-
11.274- (when-let* ((a (progn (print :a) 1))
11.275- (b (progn (print :b) (1+ a)))
11.276- (list a b))
11.277- ; =>
11.278- :A
11.279- :B
11.280- (1 2)
11.281-
11.282- (when-let* ((a (progn (print :a) nil))
11.283- (b (progn (print :b) (1+ a))))
11.284- (list a b))
11.285- ; =>
11.286- :A
11.287- NIL
11.288-
11.289- "
11.290- (with-gensyms (block)
11.291- `(block ,block
11.292- (let* ,(loop :for (symbol value) :in bindings
11.293- :collect `(,symbol (or ,value
11.294- (return-from ,block nil))))
11.295- ,@body))))
11.296-
11.297-(defmacro if-let (bindings &body body)
11.298- "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.
11.299-
11.300- `body` must be of the form `(...optional-declarations... then else)`.
11.301-
11.302- This macro combines `if` and `let`. It takes a list of bindings and
11.303- binds them like `let` before executing the `then` branch of `body`, but
11.304- if any binding's value evaluates to `nil` the process stops there and the
11.305- `else` branch is immediately executed (with no bindings in effect).
11.306-
11.307- If any `optional-declarations` are included they will only be in effect
11.308- for the `then` branch.
11.309-
11.310- Examples:
11.311-
11.312- (if-let ((a (progn (print :a) 1))
11.313- (b (progn (print :b) 2)))
11.314- (list a b)
11.315- 'nope)
11.316- ; =>
11.317- :A
11.318- :B
11.319- (1 2)
11.320-
11.321- (if-let ((a (progn (print :a) nil))
11.322- (b (progn (print :b) 2)))
11.323- (list a b)
11.324- 'nope)
11.325- ; =>
11.326- :A
11.327- NOPE
11.328-
11.329- "
11.330- (with-gensyms (outer inner)
11.331- (multiple-value-bind (body declarations) (parse-body body)
11.332- (destructuring-bind (then else) body
11.333- `(block ,outer
11.334- (block ,inner
11.335- (let ,(loop :for (symbol value) :in bindings
11.336- :collect `(,symbol (or ,value
11.337- (return-from ,inner nil))))
11.338- ,@declarations
11.339- (return-from ,outer ,then)))
11.340- ,else)))))
11.341-
11.342-(defmacro if-let* (bindings then else)
11.343- "Bind `bindings` serially and execute `then` if all are true, or `else` otherwise.
11.344-
11.345- This macro combines `if` and `let*`. It takes a list of bindings and
11.346- binds them like `let*` before executing `then`, but if any binding's
11.347- value evaluates to `nil` the process stops and the `else` branch is
11.348- immediately executed (with no bindings in effect).
11.349-
11.350- Examples:
11.351-
11.352- (if-let* ((a (progn (print :a) 1))
11.353- (b (progn (print :b) (1+ a)))
11.354- (list a b)
11.355- 'nope)
11.356- ; =>
11.357- :A
11.358- :B
11.359- (1 2)
11.360-
11.361- (if-let* ((a (progn (print :a) nil))
11.362- (b (progn (print :b) (1+ a))))
11.363- (list a b)
11.364- 'nope)
11.365- ; =>
11.366- :A
11.367- NOPE
11.368-
11.369- "
11.370- (with-gensyms (outer inner)
11.371- `(block ,outer
11.372- (block ,inner
11.373- (let* ,(loop :for (symbol value) :in bindings
11.374- :collect `(,symbol (or ,value
11.375- (return-from ,inner nil))))
11.376- (return-from ,outer ,then)))
11.377- ,else)))
11.378-
11.379-
11.380-(defmacro def! (name &body body)
11.381- "`defun' without args."
11.382- `(defun ,name () ,@body))
11.383-
11.384-(defmacro eval-always (&body body)
11.385- `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body))
11.386-
11.387-;;; TODO 2023-09-04: Env
11.388-
11.389-;;; Introspection
11.390-;; (eval-always (require :sb-introspect))
11.391-
11.392-;; (reexport-from :sb-introspect
11.393-;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit
11.394-;; :method-combination-lambda-list :deftype-lambda-list
11.395-;; :primitive-object-size :allocation-information
11.396-;; :function-type
11.397-;; :who-specializes-directly :who-specializes-generally
11.398-;; :find-function-callees :find-function-callers))
11.399-
11.400-;; ;;; Compiler
11.401-
11.402-;; (reexport-from :sb-c
11.403-;; :include '(:define-source-transformation
11.404-;; :parse-eval-when-situations
11.405-;; :source-location))
11.406-;;; Definitions
11.407-(defun %reevaluate-constant (name value test)
11.408- (if (not (boundp name))
11.409- value
11.410- (let ((old (symbol-value name))
11.411- (new value))
11.412- (if (not (constantp name))
11.413- (prog1 new
11.414- (cerror "Try to redefine the variable as a constant."
11.415- "~@<~S is an already bound non-constant variable ~
11.416- whose value is ~S.~:@>" name old))
11.417- (if (funcall test old new)
11.418- old
11.419- (restart-case
11.420- (error "~@<~S is an already defined constant whose value ~
11.421- ~S is not equal to the provided initial value ~S ~
11.422- under ~S.~:@>" name old new test)
11.423- (ignore ()
11.424- :report "Retain the current value."
11.425- old)
11.426- (continue ()
11.427- :report "Try to redefine the constant."
11.428- new)))))))
11.429-
11.430-(defmacro define-constant (name initial-value &key (test #'eql) documentation)
11.431- "Ensures that the global variable named by NAME is a constant with a value
11.432-that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
11.433-/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
11.434-becomes the documentation string of the constant.
11.435-
11.436-Signals an error if NAME is already a bound non-constant variable.
11.437-
11.438-Signals an error if NAME is already a constant variable whose value is not
11.439-equal under TEST to result of evaluating INITIAL-VALUE."
11.440- `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
11.441- ,@(when documentation `(,documentation))))
11.442-
11.443-;;; Named Lambdas
11.444-;; (reexport-from :sb-int :include '(:make-macro-lambda :parse-lambda-list))
11.445-
11.446-;;; Sexp utils
11.447-;; (reexport-from :uiop :include '(read-file-form read-file-forms slurp-stream-forms))
11.448-
11.449-;;; cl-bench utils
11.450-;; Destructive merge of two sorted lists.
11.451-;; From Hansen's MS thesis.
11.452-(defun merge! (a b predicate)
11.453- (labels ((merge-loop (r a b)
11.454- (cond ((funcall predicate (car b) (car a))
11.455- (setf (cdr r) b)
11.456- (if (null (cdr b))
11.457- (setf (cdr b) a)
11.458- (merge-loop b a (cdr b))))
11.459- (t ; (car a) <= (car b)
11.460- (setf (cdr r) a)
11.461- (if (null (cdr a))
11.462- (setf (cdr a) b)
11.463- (merge-loop a (cdr a) b))))))
11.464- (cond ((null a) b)
11.465- ((null b) a)
11.466- ((funcall predicate (car b) (car a))
11.467- (if (null (cdr b))
11.468- (setf (cdr b) a)
11.469- (merge-loop b a (cdr b)))
11.470- b)
11.471- (t ; (car a) <= (car b)
11.472- (if (null (cdr a))
11.473- (setf (cdr a) b)
11.474- (merge-loop a (cdr a) b))
11.475- a))))
11.476-
11.477-;; Stable sort procedure which copies the input list and then sorts
11.478-;; the new list imperatively. On the systems we have benchmarked,
11.479-;; this generic list sort has been at least as fast and usually much
11.480-;; faster than the library's sort routine.
11.481-;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren.
11.482-(defun sort! (seq predicate)
11.483- (labels ((astep (n)
11.484- (cond ((> n 2)
11.485- (let* ((j (truncate n 2))
11.486- (a (astep j))
11.487- (k (- n j))
11.488- (b (astep k)))
11.489- (merge! a b predicate)))
11.490- ((= n 2)
11.491- (let ((x (car seq))
11.492- (y (cadr seq))
11.493- (p seq))
11.494- (setf seq (cddr seq))
11.495- (when (funcall predicate y x)
11.496- (setf (car p) y)
11.497- (setf (cadr p) x))
11.498- (setf (cddr p) nil)
11.499- p))
11.500- ((= n 1)
11.501- (let ((p seq))
11.502- (setf seq (cdr seq))
11.503- (setf (cdr p) nil)
11.504- p))
11.505- (t nil))))
11.506- (astep (length seq))))
11.507-
11.508-;;; CLOS/MOP
11.509-(defun list-indirect-class-methods (class)
11.510- "List all indirect methods of CLASS."
11.511- (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class))))
11.512-
11.513-(defun list-class-methods (class methods &optional indirect)
11.514- "List all methods specializing on CLASS modulo METHODS. When INDIRECT is
11.515-non-nil, also include indirect (parent) methods."
11.516- (if (eq methods t)
11.517- (if indirect
11.518- (list-indirect-class-methods class)
11.519- (specializer-direct-generic-functions class))
11.520- (mapcar
11.521- (lambda (s)
11.522- (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name)))
11.523- methods)))
11.524-
11.525-;; FIX 2023-09-13: need exclude param
11.526-(defun list-class-slots (class slots &optional exclude)
11.527- ;; should probably convert slot-definition-name here
11.528- (let ((cs (remove-if
11.529- (lambda (s)
11.530- (or
11.531- (null s)
11.532- (member t (mapcar
11.533- (lambda (x)
11.534- (string= (slot-definition-name s) x))
11.535- exclude))))
11.536- (class-slots class))))
11.537- (if (eq slots t)
11.538- cs
11.539- (loop for s in slots
11.540- with sn = (symb s)
11.541- for c in cs
11.542- with cn = (symb (slot-definition-name c))
11.543- when (eq sn cn)
11.544- collect c))))
11.545-
11.546-;; TODO 2023-09-09: slot exclusion from dynamic var
11.547-(defun list-slot-values-using-class (class obj slots &optional nullp unboundp)
11.548- (remove-if
11.549- #'null
11.550- (mapcar
11.551- (lambda (s)
11.552- (let ((n (slot-definition-name s)))
11.553- (let ((ns (make-keyword (symbol-name n))))
11.554- (if (slot-boundp-using-class class obj s)
11.555- (let ((v (slot-value-using-class class obj s)))
11.556- (if nullp
11.557- `(,ns ,v)
11.558- (unless (null v)
11.559- `(,ns ,v))))
11.560- (when unboundp (list ns))))))
11.561- slots)))
11.562-
11.563-;;; Seq utils
11.564-
11.565-(deftype signed-array-length ()
11.566- "A (possibly negated) array length."
11.567- '#.(let ((limit (1- array-dimension-limit)))
11.568- `(integer ,(- limit) ,limit)))
11.569-
11.570-(defun take (n seq)
11.571- "Return, at most, the first N elements of SEQ, as a *new* sequence
11.572-of the same type as SEQ.
11.573-
11.574-If N is longer than SEQ, SEQ is simply copied.
11.575-
11.576-If N is negative, then |N| elements are taken (in their original
11.577-order) from the end of SEQ."
11.578- #+sbcl (declare (sb-ext:muffle-conditions style-warning))
11.579- (declare (type signed-array-length n))
11.580- (seq-dispatch seq
11.581- (if (minusp n)
11.582- (last seq (abs n))
11.583- (firstn n seq))
11.584- (if (minusp n)
11.585- (subseq seq (max 0 (+ (length seq) n)))
11.586- (subseq seq 0 (min n (length seq))))))
11.587-
11.588-;;; Hashtable utils
11.589-(declaim (inline maphash-keys))
11.590-(defun maphash-keys (function table)
11.591- "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
11.592- (maphash (lambda (k v)
11.593- (declare (ignore v))
11.594- (funcall function k))
11.595- table))
11.596-
11.597-(declaim (inline maphash-values))
11.598-(defun maphash-values (function table)
11.599- "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
11.600- (maphash (lambda (k v)
11.601- (declare (ignore k))
11.602- (funcall function v))
11.603- table))
11.604-
11.605-(defun hash-table-keys (table)
11.606- "Returns a list containing the keys of hash table TABLE."
11.607- (let ((keys nil))
11.608- (maphash-keys (lambda (k)
11.609- (push k keys))
11.610- table)
11.611- keys))
11.612-
11.613-(defun hash-table-values (table)
11.614- "Returns a list containing the values of hash table TABLE."
11.615- (let ((values nil))
11.616- (maphash-values (lambda (v)
11.617- (push v values))
11.618- table)
11.619- values))
11.620-
11.621-(defun current-lisp-implementation ()
11.622- "Return the current lisp implemenation as a cons: (TYPE VERSION)"
11.623- (list
11.624- (lisp-implementation-type)
11.625- (lisp-implementation-version)
11.626- *features*))
11.627-
11.628-;;; Franz
11.629-(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
11.630-
11.631-(defmacro if* (&rest args)
11.632- (do ((xx (reverse args) (cdr xx))
11.633- (state :init)
11.634- (elseseen nil)
11.635- (totalcol nil)
11.636- (lookat nil nil)
11.637- (col nil))
11.638- ((null xx)
11.639- (cond ((eq state :compl)
11.640- `(cond ,@totalcol))
11.641- (t (error "if*: illegal form ~s" args))))
11.642- (cond ((and (symbolp (car xx))
11.643- (member (symbol-name (car xx))
11.644- if*-keyword-list
11.645- :test #'string-equal))
11.646- (setq lookat (symbol-name (car xx)))))
11.647-
11.648- (cond ((eq state :init)
11.649- (cond (lookat (cond ((string-equal lookat "thenret")
11.650- (setq col nil
11.651- state :then))
11.652- (t (error
11.653- "if*: bad keyword ~a" lookat))))
11.654- (t (setq state :col
11.655- col nil)
11.656- (push (car xx) col))))
11.657- ((eq state :col)
11.658- (cond (lookat
11.659- (cond ((string-equal lookat "else")
11.660- (cond (elseseen
11.661- (error
11.662- "if*: multiples elses")))
11.663- (setq elseseen t)
11.664- (setq state :init)
11.665- (push `(t ,@col) totalcol))
11.666- ((string-equal lookat "then")
11.667- (setq state :then))
11.668- (t (error "if*: bad keyword ~s"
11.669- lookat))))
11.670- (t (push (car xx) col))))
11.671- ((eq state :then)
11.672- (cond (lookat
11.673- (error
11.674- "if*: keyword ~s at the wrong place " (car xx)))
11.675- (t (setq state :compl)
11.676- (push `(,(car xx) ,@col) totalcol))))
11.677- ((eq state :compl)
11.678- (cond ((not (string-equal lookat "elseif"))
11.679- (error "if*: missing elseif clause ")))
11.680- (setq state :init)))))
11.681-
11.682-(defun tmpfile (size)
11.683- "Create an anonymous temporary file of the given size. Returns a file descriptor."
11.684- (let (done fd pathname)
11.685- (unwind-protect
11.686- (progn
11.687- (setf (values fd pathname) (sb-posix:mkstemp "/dev/shm/tmp.XXXXXXXX"))
11.688- (sb-posix:unlink pathname)
11.689- (sb-posix:ftruncate fd size)
11.690- (setf done t))
11.691- (when (and fd (not done)) (sb-posix:close fd)))
11.692- fd))
11.693-
11.694-;;; Alexandria Functions
11.695-(declaim (inline ensure-function))
11.696-
11.697-(declaim (ftype (function (t) (values function &optional))
11.698- ensure-function))
11.699-(defun ensure-function (function-designator)
11.700- "Returns the function designated by FUNCTION-DESIGNATOR:
11.701-if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
11.702-it must be a function name and its FDEFINITION is returned."
11.703- (if (functionp function-designator)
11.704- function-designator
11.705- (fdefinition function-designator)))
11.706-
11.707-(define-modify-macro ensure-functionf/1 () ensure-function)
11.708-
11.709-(defmacro ensure-functionf (&rest places)
11.710- "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
11.711-PLACES contains a function."
11.712- `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
11.713-
11.714-(defun disjoin (predicate &rest more-predicates)
11.715- "Returns a function that applies each of PREDICATE and MORE-PREDICATE
11.716-functions in turn to its arguments, returning the primary value of the first
11.717-predicate that returns true, without calling the remaining predicates.
11.718-If none of the predicates returns true, NIL is returned."
11.719- (declare (optimize (speed 3) (safety 1) (debug 1)))
11.720- (let ((predicate (ensure-function predicate))
11.721- (more-predicates (mapcar #'ensure-function more-predicates)))
11.722- (lambda (&rest arguments)
11.723- (or (apply predicate arguments)
11.724- (some (lambda (p)
11.725- (declare (type function p))
11.726- (apply p arguments))
11.727- more-predicates)))))
11.728-
11.729-(defun conjoin (predicate &rest more-predicates)
11.730- "Returns a function that applies each of PREDICATE and MORE-PREDICATE
11.731-functions in turn to its arguments, returning NIL if any of the predicates
11.732-returns false, without calling the remaining predicates. If none of the
11.733-predicates returns false, returns the primary value of the last predicate."
11.734- (if (null more-predicates)
11.735- predicate
11.736- (lambda (&rest arguments)
11.737- (and (apply predicate arguments)
11.738- ;; Cannot simply use CL:EVERY because we want to return the
11.739- ;; non-NIL value of the last predicate if all succeed.
11.740- (do ((tail (cdr more-predicates) (cdr tail))
11.741- (head (car more-predicates) (car tail)))
11.742- ((not tail)
11.743- (apply head arguments))
11.744- (unless (apply head arguments)
11.745- (return nil)))))))
11.746-
11.747-(defun compose (function &rest more-functions)
11.748- "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
11.749-arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
11.750-and then calling the next one with the primary value of the last."
11.751- (declare (optimize (speed 3) (safety 1) (debug 1)))
11.752- (reduce (lambda (f g)
11.753- (let ((f (ensure-function f))
11.754- (g (ensure-function g)))
11.755- (lambda (&rest arguments)
11.756- (declare (dynamic-extent arguments))
11.757- (funcall f (apply g arguments)))))
11.758- more-functions
11.759- :initial-value function))
11.760-
11.761-(define-compiler-macro compose (function &rest more-functions)
11.762- (labels ((compose-1 (funs)
11.763- (if (cdr funs)
11.764- `(funcall ,(car funs) ,(compose-1 (cdr funs)))
11.765- `(apply ,(car funs) arguments))))
11.766- (let* ((args (cons function more-functions))
11.767- (funs (make-gensym-list (length args) "COMPOSE")))
11.768- `(let ,(loop for f in funs for arg in args
11.769- collect `(,f (ensure-function ,arg)))
11.770- (declare (optimize (speed 3) (safety 1) (debug 1)))
11.771- (lambda (&rest arguments)
11.772- (declare (dynamic-extent arguments))
11.773- ,(compose-1 funs))))))
11.774-
11.775-(defun multiple-value-compose (function &rest more-functions)
11.776- "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
11.777-its arguments to each in turn, starting from the rightmost of
11.778-MORE-FUNCTIONS, and then calling the next one with all the return values of
11.779-the last."
11.780- (declare (optimize (speed 3) (safety 1) (debug 1)))
11.781- (reduce (lambda (f g)
11.782- (let ((f (ensure-function f))
11.783- (g (ensure-function g)))
11.784- (lambda (&rest arguments)
11.785- (declare (dynamic-extent arguments))
11.786- (multiple-value-call f (apply g arguments)))))
11.787- more-functions
11.788- :initial-value function))
11.789-
11.790-(define-compiler-macro multiple-value-compose (function &rest more-functions)
11.791- (labels ((compose-1 (funs)
11.792- (if (cdr funs)
11.793- `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
11.794- `(apply ,(car funs) arguments))))
11.795- (let* ((args (cons function more-functions))
11.796- (funs (make-gensym-list (length args) "MV-COMPOSE")))
11.797- `(let ,(mapcar #'list funs args)
11.798- (declare (optimize (speed 3) (safety 1) (debug 1)))
11.799- (lambda (&rest arguments)
11.800- (declare (dynamic-extent arguments))
11.801- ,(compose-1 funs))))))
11.802-
11.803-(declaim (inline curry rcurry))
11.804-
11.805-(defun curry (function &rest arguments)
11.806- "Returns a function that applies ARGUMENTS and the arguments
11.807-it is called with to FUNCTION."
11.808- (declare (optimize (speed 3) (safety 1)))
11.809- (let ((fn (ensure-function function)))
11.810- (lambda (&rest more)
11.811- (declare (dynamic-extent more))
11.812- ;; Using M-V-C we don't need to append the arguments.
11.813- (multiple-value-call fn (values-list arguments) (values-list more)))))
11.814-
11.815-(define-compiler-macro curry (function &rest arguments)
11.816- (let ((curries (make-gensym-list (length arguments) "CURRY"))
11.817- (fun (gensym "FUN")))
11.818- `(let ((,fun (ensure-function ,function))
11.819- ,@(mapcar #'list curries arguments))
11.820- (declare (optimize (speed 3) (safety 1)))
11.821- (lambda (&rest more)
11.822- (declare (dynamic-extent more))
11.823- (apply ,fun ,@curries more)))))
11.824-
11.825-(defun rcurry (function &rest arguments)
11.826- "Returns a function that applies the arguments it is called
11.827-with and ARGUMENTS to FUNCTION."
11.828- (declare (optimize (speed 3) (safety 1)))
11.829- (let ((fn (ensure-function function)))
11.830- (lambda (&rest more)
11.831- (declare (dynamic-extent more))
11.832- (multiple-value-call fn (values-list more) (values-list arguments)))))
11.833-
11.834-(define-compiler-macro rcurry (function &rest arguments)
11.835- (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
11.836- (fun (gensym "FUN")))
11.837- `(let ((,fun (ensure-function ,function))
11.838- ,@(mapcar #'list rcurries arguments))
11.839- (declare (optimize (speed 3) (safety 1)))
11.840- (lambda (&rest more)
11.841- (declare (dynamic-extent more))
11.842- (multiple-value-call ,fun (values-list more) ,@rcurries)))))
11.843-
11.844-(declaim (notinline curry rcurry))
11.845-
11.846-
11.847-(defmacro named-lambda (name lambda-list &body body)
11.848- "Expands into a lambda-expression within whose BODY NAME denotes the
11.849-corresponding function."
11.850- `(labels ((,name ,lambda-list ,@body))
11.851- #',name))
11.852-
11.853-;;; array utils
11.854-
11.855-(defun copy-array (array)
11.856- (let ((new-array
11.857- (make-array (array-dimensions array)
11.858- :element-type (array-element-type array)
11.859- :adjustable (adjustable-array-p array)
11.860- :fill-pointer (and (array-has-fill-pointer-p array)
11.861- (fill-pointer array)))))
11.862- (loop for i below (array-total-size array)
11.863- do (setf (row-major-aref new-array i)
11.864- (row-major-aref array i)))
11.865- new-array))
11.866-
11.867-;;; hash-table utils
11.868-(defun hash-table-alist (table)
11.869- "Returns an association list containing the keys and values of hash table
11.870-TABLE."
11.871- (let ((alist nil))
11.872- (maphash (lambda (k v)
11.873- (push (cons k v) alist))
11.874- table)
11.875- alist))
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/std/fu/curry.lisp Mon Apr 22 23:14:47 2024 -0400
12.3@@ -0,0 +1,159 @@
12.4+;;; std/fu/curry.lisp --- Standard Currying Functors
12.5+
12.6+;;
12.7+
12.8+;;; Code:
12.9+(in-package :std/fu)
12.10+
12.11+;;; Alexandria Functions
12.12+(declaim (inline ensure-function))
12.13+
12.14+(declaim (ftype (function (t) (values function &optional))
12.15+ ensure-function))
12.16+(defun ensure-function (function-designator)
12.17+ "Returns the function designated by FUNCTION-DESIGNATOR:
12.18+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
12.19+it must be a function name and its FDEFINITION is returned."
12.20+ (if (functionp function-designator)
12.21+ function-designator
12.22+ (fdefinition function-designator)))
12.23+
12.24+(define-modify-macro ensure-functionf/1 () ensure-function)
12.25+
12.26+(defmacro ensure-functionf (&rest places)
12.27+ "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
12.28+PLACES contains a function."
12.29+ `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
12.30+
12.31+(defun disjoin (predicate &rest more-predicates)
12.32+ "Returns a function that applies each of PREDICATE and MORE-PREDICATE
12.33+functions in turn to its arguments, returning the primary value of the first
12.34+predicate that returns true, without calling the remaining predicates.
12.35+If none of the predicates returns true, NIL is returned."
12.36+ (declare (optimize (speed 3) (safety 1) (debug 1)))
12.37+ (let ((predicate (ensure-function predicate))
12.38+ (more-predicates (mapcar #'ensure-function more-predicates)))
12.39+ (lambda (&rest arguments)
12.40+ (or (apply predicate arguments)
12.41+ (some (lambda (p)
12.42+ (declare (type function p))
12.43+ (apply p arguments))
12.44+ more-predicates)))))
12.45+
12.46+(defun conjoin (predicate &rest more-predicates)
12.47+ "Returns a function that applies each of PREDICATE and MORE-PREDICATE
12.48+functions in turn to its arguments, returning NIL if any of the predicates
12.49+returns false, without calling the remaining predicates. If none of the
12.50+predicates returns false, returns the primary value of the last predicate."
12.51+ (if (null more-predicates)
12.52+ predicate
12.53+ (lambda (&rest arguments)
12.54+ (and (apply predicate arguments)
12.55+ ;; Cannot simply use CL:EVERY because we want to return the
12.56+ ;; non-NIL value of the last predicate if all succeed.
12.57+ (do ((tail (cdr more-predicates) (cdr tail))
12.58+ (head (car more-predicates) (car tail)))
12.59+ ((not tail)
12.60+ (apply head arguments))
12.61+ (unless (apply head arguments)
12.62+ (return nil)))))))
12.63+
12.64+(defun compose (function &rest more-functions)
12.65+ "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
12.66+arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
12.67+and then calling the next one with the primary value of the last."
12.68+ (declare (optimize (speed 3) (safety 1) (debug 1)))
12.69+ (reduce (lambda (f g)
12.70+ (let ((f (ensure-function f))
12.71+ (g (ensure-function g)))
12.72+ (lambda (&rest arguments)
12.73+ (declare (dynamic-extent arguments))
12.74+ (funcall f (apply g arguments)))))
12.75+ more-functions
12.76+ :initial-value function))
12.77+
12.78+(define-compiler-macro compose (function &rest more-functions)
12.79+ (labels ((compose-1 (funs)
12.80+ (if (cdr funs)
12.81+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
12.82+ `(apply ,(car funs) arguments))))
12.83+ (let* ((args (cons function more-functions))
12.84+ (funs (make-gensym-list (length args) "COMPOSE")))
12.85+ `(let ,(loop for f in funs for arg in args
12.86+ collect `(,f (ensure-function ,arg)))
12.87+ (declare (optimize (speed 3) (safety 1) (debug 1)))
12.88+ (lambda (&rest arguments)
12.89+ (declare (dynamic-extent arguments))
12.90+ ,(compose-1 funs))))))
12.91+
12.92+(defun multiple-value-compose (function &rest more-functions)
12.93+ "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
12.94+its arguments to each in turn, starting from the rightmost of
12.95+MORE-FUNCTIONS, and then calling the next one with all the return values of
12.96+the last."
12.97+ (declare (optimize (speed 3) (safety 1) (debug 1)))
12.98+ (reduce (lambda (f g)
12.99+ (let ((f (ensure-function f))
12.100+ (g (ensure-function g)))
12.101+ (lambda (&rest arguments)
12.102+ (declare (dynamic-extent arguments))
12.103+ (multiple-value-call f (apply g arguments)))))
12.104+ more-functions
12.105+ :initial-value function))
12.106+
12.107+(define-compiler-macro multiple-value-compose (function &rest more-functions)
12.108+ (labels ((compose-1 (funs)
12.109+ (if (cdr funs)
12.110+ `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
12.111+ `(apply ,(car funs) arguments))))
12.112+ (let* ((args (cons function more-functions))
12.113+ (funs (make-gensym-list (length args) "MV-COMPOSE")))
12.114+ `(let ,(mapcar #'list funs args)
12.115+ (declare (optimize (speed 3) (safety 1) (debug 1)))
12.116+ (lambda (&rest arguments)
12.117+ (declare (dynamic-extent arguments))
12.118+ ,(compose-1 funs))))))
12.119+
12.120+(declaim (inline curry rcurry))
12.121+
12.122+(defun curry (function &rest arguments)
12.123+ "Returns a function that applies ARGUMENTS and the arguments
12.124+it is called with to FUNCTION."
12.125+ (declare (optimize (speed 3) (safety 1)))
12.126+ (let ((fn (ensure-function function)))
12.127+ (lambda (&rest more)
12.128+ (declare (dynamic-extent more))
12.129+ ;; Using M-V-C we don't need to append the arguments.
12.130+ (multiple-value-call fn (values-list arguments) (values-list more)))))
12.131+
12.132+(define-compiler-macro curry (function &rest arguments)
12.133+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
12.134+ (fun (gensym "FUN")))
12.135+ `(let ((,fun (ensure-function ,function))
12.136+ ,@(mapcar #'list curries arguments))
12.137+ (declare (optimize (speed 3) (safety 1)))
12.138+ (lambda (&rest more)
12.139+ (declare (dynamic-extent more))
12.140+ (apply ,fun ,@curries more)))))
12.141+
12.142+(defun rcurry (function &rest arguments)
12.143+ "Returns a function that applies the arguments it is called
12.144+with and ARGUMENTS to FUNCTION."
12.145+ (declare (optimize (speed 3) (safety 1)))
12.146+ (let ((fn (ensure-function function)))
12.147+ (lambda (&rest more)
12.148+ (declare (dynamic-extent more))
12.149+ (multiple-value-call fn (values-list more) (values-list arguments)))))
12.150+
12.151+(define-compiler-macro rcurry (function &rest arguments)
12.152+ (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
12.153+ (fun (gensym "FUN")))
12.154+ `(let ((,fun (ensure-function ,function))
12.155+ ,@(mapcar #'list rcurries arguments))
12.156+ (declare (optimize (speed 3) (safety 1)))
12.157+ (lambda (&rest more)
12.158+ (declare (dynamic-extent more))
12.159+ (multiple-value-call ,fun (values-list more) ,@rcurries)))))
12.160+
12.161+(declaim (notinline curry rcurry))
12.162+
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/lisp/std/hash-table.lisp Mon Apr 22 23:14:47 2024 -0400
13.3@@ -0,0 +1,47 @@
13.4+;;; std/hash-table.lisp --- Standard Hash Tables
13.5+
13.6+;;
13.7+
13.8+;;; Code:
13.9+(in-package :std/hash-table)
13.10+
13.11+(declaim (inline maphash-keys))
13.12+(defun maphash-keys (function table)
13.13+ "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
13.14+ (maphash (lambda (k v)
13.15+ (declare (ignore v))
13.16+ (funcall function k))
13.17+ table))
13.18+
13.19+(declaim (inline maphash-values))
13.20+(defun maphash-values (function table)
13.21+ "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
13.22+ (maphash (lambda (k v)
13.23+ (declare (ignore k))
13.24+ (funcall function v))
13.25+ table))
13.26+
13.27+(defun hash-table-keys (table)
13.28+ "Returns a list containing the keys of hash table TABLE."
13.29+ (let ((keys nil))
13.30+ (maphash-keys (lambda (k)
13.31+ (push k keys))
13.32+ table)
13.33+ keys))
13.34+
13.35+(defun hash-table-values (table)
13.36+ "Returns a list containing the values of hash table TABLE."
13.37+ (let ((values nil))
13.38+ (maphash-values (lambda (v)
13.39+ (push v values))
13.40+ table)
13.41+ values))
13.42+
13.43+(defun hash-table-alist (table)
13.44+ "Returns an association list containing the keys and values of hash table
13.45+TABLE."
13.46+ (let ((alist nil))
13.47+ (maphash (lambda (k v)
13.48+ (push (cons k v) alist))
13.49+ table)
13.50+ alist))
14.1--- a/lisp/std/list.lisp Sun Apr 21 22:38:49 2024 -0400
14.2+++ b/lisp/std/list.lisp Mon Apr 22 23:14:47 2024 -0400
14.3@@ -1,7 +1,7 @@
14.4 ;;; std/list.lisp --- List utils
14.5
14.6 ;;; Code:
14.7-(in-package :std)
14.8+(in-package :std/list)
14.9
14.10 ;; (reexport-from :sb-int
14.11 ;; :include '(:recons :memq :assq :ensure-list :proper-list-of-length-p :proper-list-p
14.12@@ -122,3 +122,60 @@
14.13 (car x)
14.14 (rec (cdr x) acc))))))
14.15 (rec x nil))))
14.16+
14.17+;;; cl-bench utils
14.18+;; Destructive merge of two sorted lists.
14.19+;; From Hansen's MS thesis.
14.20+(defun merge! (a b predicate)
14.21+ (labels ((merge-loop (r a b)
14.22+ (cond ((funcall predicate (car b) (car a))
14.23+ (setf (cdr r) b)
14.24+ (if (null (cdr b))
14.25+ (setf (cdr b) a)
14.26+ (merge-loop b a (cdr b))))
14.27+ (t ; (car a) <= (car b)
14.28+ (setf (cdr r) a)
14.29+ (if (null (cdr a))
14.30+ (setf (cdr a) b)
14.31+ (merge-loop a (cdr a) b))))))
14.32+ (cond ((null a) b)
14.33+ ((null b) a)
14.34+ ((funcall predicate (car b) (car a))
14.35+ (if (null (cdr b))
14.36+ (setf (cdr b) a)
14.37+ (merge-loop b a (cdr b)))
14.38+ b)
14.39+ (t ; (car a) <= (car b)
14.40+ (if (null (cdr a))
14.41+ (setf (cdr a) b)
14.42+ (merge-loop a (cdr a) b))
14.43+ a))))
14.44+
14.45+;; Stable sort procedure which copies the input list and then sorts
14.46+;; the new list imperatively. Due to Richard O'Keefe; algorithm
14.47+;; attributed to D.H.D. Warren.
14.48+(defun sort! (seq predicate)
14.49+ (labels ((astep (n)
14.50+ (cond ((> n 2)
14.51+ (let* ((j (truncate n 2))
14.52+ (a (astep j))
14.53+ (k (- n j))
14.54+ (b (astep k)))
14.55+ (merge! a b predicate)))
14.56+ ((= n 2)
14.57+ (let ((x (car seq))
14.58+ (y (cadr seq))
14.59+ (p seq))
14.60+ (setf seq (cddr seq))
14.61+ (when (funcall predicate y x)
14.62+ (setf (car p) y)
14.63+ (setf (cadr p) x))
14.64+ (setf (cddr p) nil)
14.65+ p))
14.66+ ((= n 1)
14.67+ (let ((p seq))
14.68+ (setf seq (cdr seq))
14.69+ (setf (cdr p) nil)
14.70+ p))
14.71+ (t nil))))
14.72+ (astep (length seq))))
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/std/macs/ana.lisp Mon Apr 22 23:14:47 2024 -0400
15.3@@ -0,0 +1,671 @@
15.4+;;; ana.lisp --- anaphoric macros
15.5+
15.6+;;; Code:
15.7+(in-package :std/macs)
15.8+
15.9+(in-readtable :std)
15.10+
15.11+;;; Named Lambdas
15.12+;; (reexport-from :sb-int :include '(:make-macro-lambda :parse-lambda-list))
15.13+
15.14+;; LoL tlist
15.15+;; (declaim (inline make-tlist tlist-left
15.16+;; tlist-right tlist-empty-p))
15.17+
15.18+;; (defun make-tlist () (cons nil nil))
15.19+;; (defun tlist-left (tl) (caar tl))
15.20+;; (defun tlist-right (tl) (cadr tl))
15.21+;; (defun tlist-empty-p (tl) (null (car tl)))
15.22+
15.23+;; (declaim (inline tlist-add-left
15.24+;; tlist-add-right))
15.25+
15.26+;; (defun tlist-add-left (tl it)
15.27+;; (let ((x (cons it (car tl))))
15.28+;; (if (tlist-empty-p tl)
15.29+;; (setf (cdr tl) x))
15.30+;; (setf (car tl) x)))
15.31+
15.32+;; (defun tlist-add-right (tl it)
15.33+;; (let ((x (cons it nil)))
15.34+;; (if (tlist-empty-p tl)
15.35+;; (setf (car tl) x)
15.36+;; (setf (cddr tl) x))
15.37+;; (setf (cdr tl) x)))
15.38+
15.39+;; (declaim (inline tlist-rem-left))
15.40+
15.41+;; (defun tlist-rem-left (tl)
15.42+;; (if (tlist-empty-p tl)
15.43+;; (error "Remove from empty tlist")
15.44+;; (let ((x (car tl)))
15.45+;; (setf (car tl) (cdar tl))
15.46+;; (if (tlist-empty-p tl)
15.47+;; (setf (cdr tl) nil)) ;; For gc
15.48+;; (car x))))
15.49+
15.50+;; (declaim (inline tlist-update))
15.51+
15.52+;; (defun tlist-update (tl)
15.53+;; (setf (cdr tl) (last (car tl))))
15.54+
15.55+(defun build-batcher-sn (n)
15.56+ (let* (network
15.57+ (tee (ceiling (log n 2)))
15.58+ (p (ash 1 (- tee 1))))
15.59+ (loop while (> p 0) do
15.60+ (let ((q (ash 1 (- tee 1)))
15.61+ (r 0)
15.62+ (d p))
15.63+ (loop while (> d 0) do
15.64+ (loop for i from 0 to (- n d 1) do
15.65+ (if (= (logand i p) r)
15.66+ (push (list i (+ i d))
15.67+ network)))
15.68+ (setf d (- q p)
15.69+ q (ash q -1)
15.70+ r p)))
15.71+ (setf p (ash p -1)))
15.72+ (nreverse network)))
15.73+
15.74+(defmacro! sortf (comparator &rest places)
15.75+ (if places
15.76+ `(tagbody
15.77+ ,@(mapcar
15.78+ #`(let ((,g!a #1=,(nth (car a1) places))
15.79+ (,g!b #2=,(nth (cadr a1) places)))
15.80+ (if (,comparator ,g!b ,g!a)
15.81+ (setf #1# ,g!b
15.82+ #2# ,g!a)))
15.83+ (build-batcher-sn (length places))))))
15.84+
15.85+#+cl-ppcre
15.86+(defun dollar-symbol-p (s)
15.87+ (and (symbolp s)
15.88+ (> (length (symbol-name s)) 1)
15.89+ (string= (symbol-name s)
15.90+ "$"
15.91+ :start1 0
15.92+ :end1 1)
15.93+ (ignore-errors (parse-integer (subseq (symbol-name s) 1)))))
15.94+
15.95+
15.96+#+cl-ppcre
15.97+(defmacro! if-match ((match-regex str) then &optional else)
15.98+ (let* ((dollars (remove-duplicates
15.99+ (remove-if-not #'dollar-symbol-p
15.100+ (flatten then))))
15.101+ (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>))
15.102+ 0)))
15.103+ `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str)
15.104+ (declare (ignorable ,g!matches ,g!captures))
15.105+ (let ((,g!captures-len (length ,g!captures)))
15.106+ (declare (ignorable ,g!captures-len))
15.107+ (symbol-macrolet ,(mapcar #`(,(symb "$" a1)
15.108+ (if (< ,g!captures-len ,a1)
15.109+ (error "Too few matchs: ~a unbound." ,(mkstr "$" a1))
15.110+ (aref ,g!captures ,(1- a1))))
15.111+ (loop for i from 1 to top collect i))
15.112+ (if ,g!matches
15.113+ ,then
15.114+ ,else))))))
15.115+
15.116+(defun g!-symbol-p (s)
15.117+ (and (symbolp s)
15.118+ (> (length (symbol-name s)) 2)
15.119+ (string= (symbol-name s)
15.120+ "G!"
15.121+ :start1 0
15.122+ :end1 2)))
15.123+
15.124+(defun o!-symbol-p (s)
15.125+ (and (symbolp s)
15.126+ (> (length (symbol-name s)) 2)
15.127+ (string= (symbol-name s)
15.128+ "O!"
15.129+ :start1 0
15.130+ :end1 2)))
15.131+
15.132+(defun o!-symbol-to-g!-symbol (s)
15.133+ (symb "G!"
15.134+ (subseq (symbol-name s) 2)))
15.135+
15.136+#+cl-ppcre
15.137+(defmacro when-match ((match-regex str) &body forms)
15.138+ `(if-match (,match-regex ,str)
15.139+ (progn ,@forms)))
15.140+
15.141+(defmacro once-only (specs &body forms)
15.142+ "Constructs code whose primary goal is to help automate the handling of
15.143+multiple evaluation within macros. Multiple evaluation is handled by introducing
15.144+intermediate variables, in order to reuse the result of an expression.
15.145+
15.146+The returned value is a list of the form
15.147+
15.148+ (let ((<gensym-1> <expr-1>)
15.149+ ...
15.150+ (<gensym-n> <expr-n>))
15.151+ <res>)
15.152+
15.153+where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
15.154+to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
15.155+evaluating the implicit progn FORMS within a special context determined by
15.156+SPECS. RES should make use of (reference) the intermediate variables.
15.157+
15.158+Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
15.159+Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
15.160+
15.161+Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
15.162+
15.163+- INITFORM is an expression evaluated to produce EXPR-i
15.164+
15.165+- SYMBOL is the name of the variable that will be bound around FORMS to the
15.166+ corresponding gensym GENSYM-i, in order for FORMS to generate RES that
15.167+ references the intermediate variable
15.168+
15.169+The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
15.170+all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
15.171+
15.172+Example:
15.173+
15.174+ The following expression
15.175+
15.176+ (let ((x '(incf y)))
15.177+ (once-only (x)
15.178+ `(cons ,x ,x)))
15.179+
15.180+ ;;; =>
15.181+ ;;; (let ((#1=#:X123 (incf y)))
15.182+ ;;; (cons #1# #1#))
15.183+
15.184+ could be used within a macro to avoid multiple evaluation like so
15.185+
15.186+ (defmacro cons1 (x)
15.187+ (once-only (x)
15.188+ `(cons ,x ,x)))
15.189+
15.190+ (let ((y 0))
15.191+ (cons1 (incf y)))
15.192+
15.193+ ;;; => (1 . 1)
15.194+
15.195+Example:
15.196+
15.197+ The following expression demonstrates the usage of the INITFORM field
15.198+
15.199+ (let ((expr '(incf y)))
15.200+ (once-only ((var `(1+ ,expr)))
15.201+ `(list ',expr ,var ,var)))
15.202+
15.203+ ;;; =>
15.204+ ;;; (let ((#1=#:VAR123 (1+ (incf y))))
15.205+ ;;; (list '(incf y) #1# #1))
15.206+
15.207+ which could be used like so
15.208+
15.209+ (defmacro print-succ-twice (expr)
15.210+ (once-only ((var `(1+ ,expr)))
15.211+ `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
15.212+
15.213+ (let ((y 10))
15.214+ (print-succ-twice (incf y)))
15.215+
15.216+ ;;; >>
15.217+ ;;; Expr: (INCF Y), Once: 12, Twice: 12"
15.218+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
15.219+ (names-and-forms (mapcar (lambda (spec)
15.220+ (etypecase spec
15.221+ (list
15.222+ (destructuring-bind (name form) spec
15.223+ (cons name form)))
15.224+ (symbol
15.225+ (cons spec spec))))
15.226+ specs)))
15.227+ ;; bind in user-macro
15.228+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
15.229+ gensyms names-and-forms)
15.230+ ;; bind in final expansion
15.231+ `(let (,,@(mapcar (lambda (g n)
15.232+ ``(,,g ,,(cdr n)))
15.233+ gensyms names-and-forms))
15.234+ ;; bind in user-macro
15.235+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
15.236+ names-and-forms gensyms)
15.237+ ,@forms)))))
15.238+
15.239+;;;; DESTRUCTURING-*CASE
15.240+
15.241+(defun expand-destructuring-case (key clauses case)
15.242+ (once-only (key)
15.243+ `(if (typep ,key 'cons)
15.244+ (,case (car ,key)
15.245+ ,@(mapcar (lambda (clause)
15.246+ (destructuring-bind ((keys . lambda-list) &body body) clause
15.247+ `(,keys
15.248+ (destructuring-bind ,lambda-list (cdr ,key)
15.249+ ,@body))))
15.250+ clauses))
15.251+ (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
15.252+
15.253+(defmacro destructuring-case (keyform &body clauses)
15.254+ "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
15.255+KEYFORM must evaluate to a CONS.
15.256+
15.257+Clauses are of the form:
15.258+
15.259+ ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
15.260+
15.261+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
15.262+is selected, and FORMs are then executed with CDR of KEY is destructured and
15.263+bound by the DESTRUCTURING-LAMBDA-LIST.
15.264+
15.265+Example:
15.266+
15.267+ (defun dcase (x)
15.268+ (destructuring-case x
15.269+ ((:foo a b)
15.270+ (format nil \"foo: ~S, ~S\" a b))
15.271+ ((:bar &key a b)
15.272+ (format nil \"bar: ~S, ~S\" a b))
15.273+ (((:alt1 :alt2) a)
15.274+ (format nil \"alt: ~S\" a))
15.275+ ((t &rest rest)
15.276+ (format nil \"unknown: ~S\" rest))))
15.277+
15.278+ (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
15.279+ (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
15.280+ (dcase (list :alt1 1)) ; => \"alt: 1\"
15.281+ (dcase (list :alt2 2)) ; => \"alt: 2\"
15.282+ (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
15.283+
15.284+ (defun decase (x)
15.285+ (destructuring-case x
15.286+ ((:foo a b)
15.287+ (format nil \"foo: ~S, ~S\" a b))
15.288+ ((:bar &key a b)
15.289+ (format nil \"bar: ~S, ~S\" a b))
15.290+ (((:alt1 :alt2) a)
15.291+ (format nil \"alt: ~S\" a))))
15.292+
15.293+ (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
15.294+ (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
15.295+ (decase (list :alt1 1)) ; => \"alt: 1\"
15.296+ (decase (list :alt2 2)) ; => \"alt: 2\"
15.297+ (decase (list :quux 1 2 3)) ; =| error
15.298+"
15.299+ (expand-destructuring-case keyform clauses 'case))
15.300+
15.301+(defmacro destructuring-ccase (keyform &body clauses)
15.302+ (expand-destructuring-case keyform clauses 'ccase))
15.303+
15.304+(defmacro destructuring-ecase (keyform &body clauses)
15.305+ (expand-destructuring-case keyform clauses 'ecase))
15.306+
15.307+(dolist (name '(destructuring-ccase destructuring-ecase))
15.308+ (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
15.309+
15.310+;;; *-let --- control-flow let-binding macros
15.311+;; based on https://stevelosh.com/blog/2018/07/fun-with-macros-if-let/
15.312+
15.313+(defmacro when-let (bindings &body body)
15.314+ "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.
15.315+
15.316+ This macro combines `when` and `let`. It takes a list of bindings and
15.317+ binds them like `let` before executing `body`, but if any binding's value
15.318+ evaluates to `nil` the process stops and `nil` is immediately returned.
15.319+
15.320+ Examples:
15.321+
15.322+ (when-let ((a (progn (print :a) 1))
15.323+ (b (progn (print :b) 2))
15.324+ (list a b))
15.325+ ; =>
15.326+ :A
15.327+ :B
15.328+ (1 2)
15.329+
15.330+ (when-let ((a (progn (print :a) nil))
15.331+ (b (progn (print :b) 2)))
15.332+ (list a b))
15.333+ ; =>
15.334+ :A
15.335+ NIL
15.336+
15.337+ "
15.338+ (with-gensyms (block)
15.339+ `(block ,block
15.340+ (let ,(loop :for (symbol value) :in bindings
15.341+ :collect `(,symbol (or ,value
15.342+ (return-from ,block nil))))
15.343+ ,@body))))
15.344+
15.345+(defmacro when-let* (bindings &body body)
15.346+ "Bind `bindings` serially and execute `body`, short-circuiting on `nil`.
15.347+
15.348+ This macro combines `when` and `let*`. It takes a list of bindings
15.349+ and binds them like `let*` before executing `body`, but if any
15.350+ binding's value evaluates to `nil` the process stops and `nil` is
15.351+ immediately returned.
15.352+
15.353+ Examples:
15.354+
15.355+ (when-let* ((a (progn (print :a) 1))
15.356+ (b (progn (print :b) (1+ a)))
15.357+ (list a b))
15.358+ ; =>
15.359+ :A
15.360+ :B
15.361+ (1 2)
15.362+
15.363+ (when-let* ((a (progn (print :a) nil))
15.364+ (b (progn (print :b) (1+ a))))
15.365+ (list a b))
15.366+ ; =>
15.367+ :A
15.368+ NIL
15.369+
15.370+ "
15.371+ (with-gensyms (block)
15.372+ `(block ,block
15.373+ (let* ,(loop :for (symbol value) :in bindings
15.374+ :collect `(,symbol (or ,value
15.375+ (return-from ,block nil))))
15.376+ ,@body))))
15.377+
15.378+(defmacro if-let (bindings &body body)
15.379+ "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.
15.380+
15.381+ `body` must be of the form `(...optional-declarations... then else)`.
15.382+
15.383+ This macro combines `if` and `let`. It takes a list of bindings and
15.384+ binds them like `let` before executing the `then` branch of `body`, but
15.385+ if any binding's value evaluates to `nil` the process stops there and the
15.386+ `else` branch is immediately executed (with no bindings in effect).
15.387+
15.388+ If any `optional-declarations` are included they will only be in effect
15.389+ for the `then` branch.
15.390+
15.391+ Examples:
15.392+
15.393+ (if-let ((a (progn (print :a) 1))
15.394+ (b (progn (print :b) 2)))
15.395+ (list a b)
15.396+ 'nope)
15.397+ ; =>
15.398+ :A
15.399+ :B
15.400+ (1 2)
15.401+
15.402+ (if-let ((a (progn (print :a) nil))
15.403+ (b (progn (print :b) 2)))
15.404+ (list a b)
15.405+ 'nope)
15.406+ ; =>
15.407+ :A
15.408+ NOPE
15.409+
15.410+ "
15.411+ (with-gensyms (outer inner)
15.412+ (multiple-value-bind (body declarations) (parse-body body)
15.413+ (destructuring-bind (then else) body
15.414+ `(block ,outer
15.415+ (block ,inner
15.416+ (let ,(loop :for (symbol value) :in bindings
15.417+ :collect `(,symbol (or ,value
15.418+ (return-from ,inner nil))))
15.419+ ,@declarations
15.420+ (return-from ,outer ,then)))
15.421+ ,else)))))
15.422+
15.423+(defmacro if-let* (bindings then else)
15.424+ "Bind `bindings` serially and execute `then` if all are true, or `else` otherwise.
15.425+
15.426+ This macro combines `if` and `let*`. It takes a list of bindings and
15.427+ binds them like `let*` before executing `then`, but if any binding's
15.428+ value evaluates to `nil` the process stops and the `else` branch is
15.429+ immediately executed (with no bindings in effect).
15.430+
15.431+ Examples:
15.432+
15.433+ (if-let* ((a (progn (print :a) 1))
15.434+ (b (progn (print :b) (1+ a)))
15.435+ (list a b)
15.436+ 'nope)
15.437+ ; =>
15.438+ :A
15.439+ :B
15.440+ (1 2)
15.441+
15.442+ (if-let* ((a (progn (print :a) nil))
15.443+ (b (progn (print :b) (1+ a))))
15.444+ (list a b)
15.445+ 'nope)
15.446+ ; =>
15.447+ :A
15.448+ NOPE
15.449+
15.450+ "
15.451+ (with-gensyms (outer inner)
15.452+ `(block ,outer
15.453+ (block ,inner
15.454+ (let* ,(loop :for (symbol value) :in bindings
15.455+ :collect `(,symbol (or ,value
15.456+ (return-from ,inner nil))))
15.457+ (return-from ,outer ,then)))
15.458+ ,else)))
15.459+
15.460+
15.461+(defmacro def! (name &body body)
15.462+ "`defun' without args."
15.463+ `(defun ,name () ,@body))
15.464+
15.465+(defmacro eval-always (&body body)
15.466+ `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body))
15.467+
15.468+;;; Franz
15.469+(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
15.470+
15.471+(defmacro if* (&rest args)
15.472+ (do ((xx (reverse args) (cdr xx))
15.473+ (state :init)
15.474+ (elseseen nil)
15.475+ (totalcol nil)
15.476+ (lookat nil nil)
15.477+ (col nil))
15.478+ ((null xx)
15.479+ (cond ((eq state :compl)
15.480+ `(cond ,@totalcol))
15.481+ (t (error "if*: illegal form ~s" args))))
15.482+ (cond ((and (symbolp (car xx))
15.483+ (member (symbol-name (car xx))
15.484+ if*-keyword-list
15.485+ :test #'string-equal))
15.486+ (setq lookat (symbol-name (car xx)))))
15.487+
15.488+ (cond ((eq state :init)
15.489+ (cond (lookat (cond ((string-equal lookat "thenret")
15.490+ (setq col nil
15.491+ state :then))
15.492+ (t (error
15.493+ "if*: bad keyword ~a" lookat))))
15.494+ (t (setq state :col
15.495+ col nil)
15.496+ (push (car xx) col))))
15.497+ ((eq state :col)
15.498+ (cond (lookat
15.499+ (cond ((string-equal lookat "else")
15.500+ (cond (elseseen
15.501+ (error
15.502+ "if*: multiples elses")))
15.503+ (setq elseseen t)
15.504+ (setq state :init)
15.505+ (push `(t ,@col) totalcol))
15.506+ ((string-equal lookat "then")
15.507+ (setq state :then))
15.508+ (t (error "if*: bad keyword ~s"
15.509+ lookat))))
15.510+ (t (push (car xx) col))))
15.511+ ((eq state :then)
15.512+ (cond (lookat
15.513+ (error
15.514+ "if*: keyword ~s at the wrong place " (car xx)))
15.515+ (t (setq state :compl)
15.516+ (push `(,(car xx) ,@col) totalcol))))
15.517+ ((eq state :compl)
15.518+ (cond ((not (string-equal lookat "elseif"))
15.519+ (error "if*: missing elseif clause ")))
15.520+ (setq state :init)))))
15.521+
15.522+(defmacro named-lambda (name lambda-list &body body)
15.523+ "Expands into a lambda-expression within whose BODY NAME denotes the
15.524+corresponding function."
15.525+ `(labels ((,name ,lambda-list ,@body))
15.526+ #',name))
15.527+
15.528+;;; Misc
15.529+(defmacro until (condition &body body)
15.530+ (let ((block-name (gensym)))
15.531+ `(block ,block-name
15.532+ (loop
15.533+ (if ,condition
15.534+ (return-from ,block-name nil)
15.535+ (progn ,@body))))))
15.536+
15.537+(defmacro defmacro/g! (name args &rest body)
15.538+ (let ((syms (remove-duplicates
15.539+ (remove-if-not #'g!-symbol-p
15.540+ (flatten body)))))
15.541+ (multiple-value-bind (body declarations docstring)
15.542+ (parse-body body :documentation t)
15.543+ `(defmacro ,name ,args
15.544+ ,@(when docstring
15.545+ (list docstring))
15.546+ ,@declarations
15.547+ (let ,(mapcar
15.548+ (lambda (s)
15.549+ `(,s (gensym ,(subseq
15.550+ (symbol-name s)
15.551+ 2))))
15.552+ syms)
15.553+ ,@body)))))
15.554+
15.555+(defmacro defmacro! (name args &rest body)
15.556+ (let* ((os (remove-if-not #'o!-symbol-p (flatten args)))
15.557+ (gs (mapcar #'o!-symbol-to-g!-symbol os)))
15.558+ (multiple-value-bind (body declarations docstring)
15.559+ (parse-body body :documentation t)
15.560+ `(defmacro/g! ,name ,args
15.561+ ,@(when docstring
15.562+ (list docstring))
15.563+ ,@declarations
15.564+ `(let ,(mapcar #'list (list ,@gs) (list ,@os))
15.565+ ,(progn ,@body))))))
15.566+
15.567+(defmacro defun! (name args &body body)
15.568+ (let ((syms (remove-duplicates
15.569+ (remove-if-not #'g!-symbol-p
15.570+ (flatten body)))))
15.571+ (multiple-value-bind (body declarations docstring)
15.572+ (parse-body body :documentation t)
15.573+ `(defun ,name ,args
15.574+ ,@(when docstring
15.575+ (list docstring))
15.576+ ,@declarations
15.577+ (let ,(mapcar (lambda (s)
15.578+ `(,s (gensym ,(subseq (symbol-name s)
15.579+ 2))))
15.580+ syms)
15.581+ ,@body)))))
15.582+
15.583+(defmacro! dlambda (&rest ds)
15.584+ "Dynamic dispatch lambda."
15.585+ `(lambda (&rest ,g!args)
15.586+ (case (car ,g!args)
15.587+ ,@(mapcar
15.588+ (lambda (d)
15.589+ `(,(if (eq t (car d))
15.590+ t
15.591+ (list (car d)))
15.592+ (apply (lambda ,@(cdr d))
15.593+ ,(if (eq t (car d))
15.594+ g!args
15.595+ `(cdr ,g!args)))))
15.596+ ds))))
15.597+
15.598+;; Graham's alambda
15.599+(defmacro alambda (parms &body body)
15.600+ `(labels ((self ,parms ,@body))
15.601+ #'self))
15.602+
15.603+;; Graham's aif
15.604+(defmacro aif (test then &optional else)
15.605+ `(let ((it ,test))
15.606+ (if it ,then ,else)))
15.607+
15.608+;; ;; TODO 2023-09-05: wrap, document, optimize, hack
15.609+;; re-exported from SB-INT
15.610+(defmacro awhen (test &body body)
15.611+ `(let ((it ,test))
15.612+ (when it ,@body)))
15.613+
15.614+(defmacro acond (&rest clauses)
15.615+ (if (null clauses)
15.616+ `()
15.617+ (destructuring-bind ((test &body body) &rest rest) clauses
15.618+ (let ((it (copy-symbol 'it)))
15.619+ `(let ((,it ,test))
15.620+ (if ,it
15.621+ ;; Just like COND - no body means return the tested value.
15.622+ ,(if body
15.623+ `(let ((it ,it)) (declare (ignorable it)) ,@body)
15.624+ it)
15.625+ (acond ,@rest)))))))
15.626+
15.627+(defmacro! nlet-tail (n letargs &body body)
15.628+ (let ((gs (loop for i in letargs
15.629+ collect (gensym))))
15.630+ `(macrolet
15.631+ ((,n ,gs
15.632+ `(progn
15.633+ (psetq
15.634+ ,@(apply #'nconc
15.635+ (mapcar
15.636+ #'list
15.637+ ',(mapcar #'car letargs)
15.638+ (list ,@gs))))
15.639+ (go ,',g!n))))
15.640+ (block ,g!b
15.641+ (let ,letargs
15.642+ (tagbody
15.643+ ,g!n (return-from
15.644+ ,g!b (progn ,@body))))))))
15.645+
15.646+(defmacro alet% (letargs &rest body)
15.647+ `(let ((this) ,@letargs)
15.648+ (setq this ,@(last body))
15.649+ ,@(butlast body)
15.650+ this))
15.651+
15.652+(defmacro alet (letargs &rest body)
15.653+ `(let ((this) ,@letargs)
15.654+ (setq this ,@(last body))
15.655+ ,@(butlast body)
15.656+ (lambda (&rest params)
15.657+ (apply this params))))
15.658+
15.659+;; swiped from fiveam. This is just like acond except it assumes that
15.660+;; the TEST in each element of CLAUSES returns two values as opposed
15.661+;; to one.
15.662+(defmacro acond2 (&rest clauses)
15.663+ (if (null clauses)
15.664+ nil
15.665+ (with-gensyms (val foundp)
15.666+ (destructuring-bind ((test &rest progn) &rest others)
15.667+ clauses
15.668+ `(multiple-value-bind (,val ,foundp)
15.669+ ,test
15.670+ (if (or ,val ,foundp)
15.671+ (let ((it ,val))
15.672+ (declare (ignorable it))
15.673+ ,@progn)
15.674+ (acond2 ,@others)))))))
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/lisp/std/macs/const.lisp Mon Apr 22 23:14:47 2024 -0400
16.3@@ -0,0 +1,46 @@
16.4+;;; std/macs/const.lisp --- DEFINE-CONSTANT and friends
16.5+
16.6+;;
16.7+
16.8+;;; Code:
16.9+(in-package :std/macs)
16.10+;; (reexport-from :sb-c
16.11+;; :include '(:define-source-transformation
16.12+;; :parse-eval-when-situations
16.13+;; :source-location))
16.14+;;; Definitions
16.15+(defun %reevaluate-constant (name value test)
16.16+ (if (not (boundp name))
16.17+ value
16.18+ (let ((old (symbol-value name))
16.19+ (new value))
16.20+ (if (not (constantp name))
16.21+ (prog1 new
16.22+ (cerror "Try to redefine the variable as a constant."
16.23+ "~@<~S is an already bound non-constant variable ~
16.24+ whose value is ~S.~:@>" name old))
16.25+ (if (funcall test old new)
16.26+ old
16.27+ (restart-case
16.28+ (error "~@<~S is an already defined constant whose value ~
16.29+ ~S is not equal to the provided initial value ~S ~
16.30+ under ~S.~:@>" name old new test)
16.31+ (ignore ()
16.32+ :report "Retain the current value."
16.33+ old)
16.34+ (continue ()
16.35+ :report "Try to redefine the constant."
16.36+ new)))))))
16.37+
16.38+(defmacro define-constant (name initial-value &key (test #'eql) documentation)
16.39+ "Ensures that the global variable named by NAME is a constant with a value
16.40+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
16.41+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
16.42+becomes the documentation string of the constant.
16.43+
16.44+Signals an error if NAME is already a bound non-constant variable.
16.45+
16.46+Signals an error if NAME is already a constant variable whose value is not
16.47+equal under TEST to result of evaluating INITIAL-VALUE."
16.48+ `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
16.49+ ,@(when documentation `(,documentation))))
17.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
17.2+++ b/lisp/std/macs/pan.lisp Mon Apr 22 23:14:47 2024 -0400
17.3@@ -0,0 +1,84 @@
17.4+;;; pan.lisp --- Pandoric macros
17.5+
17.6+;;; Code:
17.7+(in-package :std)
17.8+(in-readtable :std)
17.9+
17.10+(defun pandoriclet-get (letargs)
17.11+ `(case sym
17.12+ ,@(mapcar #`(((car a1)) (car a1))
17.13+ letargs)
17.14+ (t (error
17.15+ "Unknown pandoric get: ~a"
17.16+ sym))))
17.17+
17.18+(defun pandoriclet-set (letargs)
17.19+ `(case sym
17.20+ ,@(mapcar #`(((car a1))
17.21+ (setq (car a1) val))
17.22+ letargs)
17.23+ (t (error
17.24+ "Unknown pandoric set: ~a"
17.25+ sym))))
17.26+
17.27+(defmacro pandoriclet (letargs &rest body)
17.28+ (let ((letargs (cons
17.29+ '(this)
17.30+ (let-binding-transform
17.31+ letargs))))
17.32+ `(let (,@letargs)
17.33+ (setq this ,@(last body))
17.34+ ,@(butlast body)
17.35+ (dlambda
17.36+ (:pandoric-get (sym)
17.37+ ,(pandoriclet-get letargs))
17.38+ (:pandoric-set (sym val)
17.39+ ,(pandoriclet-set letargs))
17.40+ (t (&rest args)
17.41+ (apply this args))))))
17.42+
17.43+(declaim (inline get-pandoric))
17.44+
17.45+(defun get-pandoric (box sym)
17.46+ (funcall box :pandoric-get sym))
17.47+
17.48+(defsetf get-pandoric (box sym) (val)
17.49+ `(progn
17.50+ (funcall ,box :pandoric-set ,sym ,val)
17.51+ ,val))
17.52+
17.53+(defmacro! with-pandoric (syms o!box &rest body)
17.54+ `(symbol-macrolet
17.55+ (,@(mapcar #`(a1 (get-pandoric ,g!box a1))
17.56+ syms))
17.57+ ,@body))
17.58+
17.59+;; (defun pandoric-hotpatch (box new)
17.60+;; (with-pandoric (this) box
17.61+;; (setq this new)))
17.62+
17.63+(defmacro pandoric-recode (vars box new)
17.64+ `(with-pandoric (this ,@vars) ,box
17.65+ (setq this ,new)))
17.66+
17.67+(defmacro plambda (largs pargs &rest body)
17.68+ (let ((pargs (mapcar #'list pargs)))
17.69+ `(let (this self)
17.70+ (setq
17.71+ this (lambda ,largs ,@body)
17.72+ self (dlambda
17.73+ (:pandoric-get (sym)
17.74+ ,(pandoriclet-get pargs))
17.75+ (:pandoric-set (sym val)
17.76+ ,(pandoriclet-set pargs))
17.77+ (t (&rest args)
17.78+ (apply this args)))))))
17.79+
17.80+(defvar pandoric-eval-tunnel)
17.81+
17.82+(defmacro pandoric-eval (vars expr)
17.83+ `(let ((pandoric-eval-tunnel
17.84+ (plambda () ,vars t)))
17.85+ (eval `(with-pandoric
17.86+ ,',vars pandoric-eval-tunnel
17.87+ ,,expr))))
18.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2+++ b/lisp/std/mop.lisp Mon Apr 22 23:14:47 2024 -0400
18.3@@ -0,0 +1,60 @@
18.4+;;; std/mop.lisp --- Standard MOP
18.5+
18.6+;;
18.7+
18.8+;;; Code:
18.9+(in-package :std/mop)
18.10+
18.11+(defun list-indirect-class-methods (class)
18.12+ "List all indirect methods of CLASS."
18.13+ (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class))))
18.14+
18.15+(defun list-class-methods (class methods &optional indirect)
18.16+ "List all methods specializing on CLASS modulo METHODS. When INDIRECT is
18.17+non-nil, also include indirect (parent) methods."
18.18+ (if (eq methods t)
18.19+ (if indirect
18.20+ (list-indirect-class-methods class)
18.21+ (specializer-direct-generic-functions class))
18.22+ (mapcar
18.23+ (lambda (s)
18.24+ (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name)))
18.25+ methods)))
18.26+
18.27+;; FIX 2023-09-13: need exclude param
18.28+(defun list-class-slots (class slots &optional exclude)
18.29+ ;; should probably convert slot-definition-name here
18.30+ (let ((cs (remove-if
18.31+ (lambda (s)
18.32+ (or
18.33+ (null s)
18.34+ (member t (mapcar
18.35+ (lambda (x)
18.36+ (string= (slot-definition-name s) x))
18.37+ exclude))))
18.38+ (class-slots class))))
18.39+ (if (eq slots t)
18.40+ cs
18.41+ (loop for s in slots
18.42+ with sn = (symb s)
18.43+ for c in cs
18.44+ with cn = (symb (slot-definition-name c))
18.45+ when (eq sn cn)
18.46+ collect c))))
18.47+
18.48+;; TODO 2023-09-09: slot exclusion from dynamic var
18.49+(defun list-slot-values-using-class (class obj slots &optional nullp unboundp)
18.50+ (remove-if
18.51+ #'null
18.52+ (mapcar
18.53+ (lambda (s)
18.54+ (let ((n (slot-definition-name s)))
18.55+ (let ((ns (make-keyword (symbol-name n))))
18.56+ (if (slot-boundp-using-class class obj s)
18.57+ (let ((v (slot-value-using-class class obj s)))
18.58+ (if nullp
18.59+ `(,ns ,v)
18.60+ (unless (null v)
18.61+ `(,ns ,v))))
18.62+ (when unboundp (list ns))))))
18.63+ slots)))
19.1--- a/lisp/std/named-readtables.lisp Sun Apr 21 22:38:49 2024 -0400
19.2+++ b/lisp/std/named-readtables.lisp Mon Apr 22 23:14:47 2024 -0400
19.3@@ -12,30 +12,6 @@
19.4 ;; behavior (using standard) versus your source code (custom).
19.5
19.6 ;;; Code:
19.7-(uiop:define-package :std/named-readtables
19.8- (:use :cl)
19.9- (:export
19.10- #:defreadtable
19.11- #:in-readtable
19.12- #:make-readtable
19.13- #:merge-readtables-into
19.14- #:find-readtable
19.15- #:ensure-readtable
19.16- #:rename-readtable
19.17- #:readtable-name
19.18- #:register-readtable
19.19- #:unregister-readtable
19.20- #:copy-named-readtable
19.21- #:list-all-named-readtables
19.22- ;; Types
19.23- #:named-readtable-designator
19.24- ;; Conditions
19.25- #:readtable-error
19.26- #:reader-macro-conflict
19.27- #:readtable-does-already-exist
19.28- #:readtable-does-not-exist
19.29- #:parse-body))
19.30-
19.31 (in-package :std/named-readtables)
19.32 (pushnew :named-readtables *features*)
19.33
20.1--- a/lisp/std/num/float.lisp Sun Apr 21 22:38:49 2024 -0400
20.2+++ b/lisp/std/num/float.lisp Mon Apr 22 23:14:47 2024 -0400
20.3@@ -9,7 +9,7 @@
20.4 ;;;
20.5 ;;; See http://common-lisp.net/project/ieee-floats/
20.6
20.7-(in-package :std)
20.8+(in-package :std/num)
20.9
20.10 ;; The following macro may look a bit overcomplicated to the casual
20.11 ;; reader. The main culprit is the fact that NaN and infinity can be
21.1--- a/lisp/std/num/parse.lisp Sun Apr 21 22:38:49 2024 -0400
21.2+++ b/lisp/std/num/parse.lisp Mon Apr 22 23:14:47 2024 -0400
21.3@@ -3,7 +3,7 @@
21.4 ;;
21.5
21.6 ;;; Code:
21.7-(in-package :std)
21.8+(in-package :std/num)
21.9
21.10 (define-condition invalid-number (parse-error)
21.11 ((value :reader invalid-number-value
22.1--- a/lisp/std/os.lisp Sun Apr 21 22:38:49 2024 -0400
22.2+++ b/lisp/std/os.lisp Mon Apr 22 23:14:47 2024 -0400
22.3@@ -3,7 +3,7 @@
22.4 ;; UNIX only.
22.5
22.6 ;;; Code:
22.7-(in-package :std)
22.8+(in-package :std/os)
22.9 (require 'sb-posix)
22.10
22.11 (defun list-all-users ()
23.1--- a/lisp/std/pan.lisp Sun Apr 21 22:38:49 2024 -0400
23.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3@@ -1,84 +0,0 @@
23.4-;;; pan.lisp --- Pandoric macros
23.5-
23.6-;;; Code:
23.7-(in-package :std)
23.8-(in-readtable :std)
23.9-
23.10-(defun pandoriclet-get (letargs)
23.11- `(case sym
23.12- ,@(mapcar #`(((car a1)) (car a1))
23.13- letargs)
23.14- (t (error
23.15- "Unknown pandoric get: ~a"
23.16- sym))))
23.17-
23.18-(defun pandoriclet-set (letargs)
23.19- `(case sym
23.20- ,@(mapcar #`(((car a1))
23.21- (setq (car a1) val))
23.22- letargs)
23.23- (t (error
23.24- "Unknown pandoric set: ~a"
23.25- sym))))
23.26-
23.27-(defmacro pandoriclet (letargs &rest body)
23.28- (let ((letargs (cons
23.29- '(this)
23.30- (let-binding-transform
23.31- letargs))))
23.32- `(let (,@letargs)
23.33- (setq this ,@(last body))
23.34- ,@(butlast body)
23.35- (dlambda
23.36- (:pandoric-get (sym)
23.37- ,(pandoriclet-get letargs))
23.38- (:pandoric-set (sym val)
23.39- ,(pandoriclet-set letargs))
23.40- (t (&rest args)
23.41- (apply this args))))))
23.42-
23.43-(declaim (inline get-pandoric))
23.44-
23.45-(defun get-pandoric (box sym)
23.46- (funcall box :pandoric-get sym))
23.47-
23.48-(defsetf get-pandoric (box sym) (val)
23.49- `(progn
23.50- (funcall ,box :pandoric-set ,sym ,val)
23.51- ,val))
23.52-
23.53-(defmacro! with-pandoric (syms o!box &rest body)
23.54- `(symbol-macrolet
23.55- (,@(mapcar #`(a1 (get-pandoric ,g!box a1))
23.56- syms))
23.57- ,@body))
23.58-
23.59-;; (defun pandoric-hotpatch (box new)
23.60-;; (with-pandoric (this) box
23.61-;; (setq this new)))
23.62-
23.63-(defmacro pandoric-recode (vars box new)
23.64- `(with-pandoric (this ,@vars) ,box
23.65- (setq this ,new)))
23.66-
23.67-(defmacro plambda (largs pargs &rest body)
23.68- (let ((pargs (mapcar #'list pargs)))
23.69- `(let (this self)
23.70- (setq
23.71- this (lambda ,largs ,@body)
23.72- self (dlambda
23.73- (:pandoric-get (sym)
23.74- ,(pandoriclet-get pargs))
23.75- (:pandoric-set (sym val)
23.76- ,(pandoriclet-set pargs))
23.77- (t (&rest args)
23.78- (apply this args)))))))
23.79-
23.80-(defvar pandoric-eval-tunnel)
23.81-
23.82-(defmacro pandoric-eval (vars expr)
23.83- `(let ((pandoric-eval-tunnel
23.84- (plambda () ,vars t)))
23.85- (eval `(with-pandoric
23.86- ,',vars pandoric-eval-tunnel
23.87- ,,expr))))
24.1--- a/lisp/std/path.lisp Sun Apr 21 22:38:49 2024 -0400
24.2+++ b/lisp/std/path.lisp Mon Apr 22 23:14:47 2024 -0400
24.3@@ -3,7 +3,7 @@
24.4 ;;
24.5
24.6 ;;; Code:
24.7-(in-package :std)
24.8+(in-package :std/path)
24.9
24.10 (deftype wild-pathname ()
24.11 "A pathname with wild components."
25.1--- a/lisp/std/pkg.lisp Sun Apr 21 22:38:49 2024 -0400
25.2+++ b/lisp/std/pkg.lisp Mon Apr 22 23:14:47 2024 -0400
25.3@@ -1,17 +1,56 @@
25.4 (pushnew :std *features*)
25.5 (pushnew "STD" *modules* :test 'equal)
25.6-(uiop:define-package :std
25.7- (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien :sb-gray :sb-concurrency)
25.8- (:use-reexport :std/named-readtables)
25.9- (:shadowing-import-from :uiop :println)
25.10- (:shadowing-import-from
25.11- :sb-int
25.12- :ensure-list :recons :memq :assq :ensure-list
25.13- :proper-list-of-length-p :proper-list-p :singleton-p
25.14- :with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*)
25.15+
25.16+(defpackage :std/named-readtables
25.17+ (:use :cl)
25.18 (:export
25.19- ;; types
25.20- ;; err
25.21+ :defreadtable
25.22+ :in-readtable
25.23+ :make-readtable
25.24+ :merge-readtables-into
25.25+ :find-readtable
25.26+ :ensure-readtable
25.27+ :rename-readtable
25.28+ :readtable-name
25.29+ :register-readtable
25.30+ :unregister-readtable
25.31+ :copy-named-readtable
25.32+ :list-all-named-readtables
25.33+ ;; Types
25.34+ :named-readtable-designator
25.35+ ;; Conditions
25.36+ :readtable-error
25.37+ :reader-macro-conflict
25.38+ :readtable-does-already-exist
25.39+ :readtable-does-not-exist
25.40+ :parse-body))
25.41+
25.42+(defpackage :std/defpkg
25.43+ (:use :cl)
25.44+ (:nicknames :pkg)
25.45+ (:export :defpkg
25.46+ :find-package* :find-symbol* :symbol-call
25.47+ :intern* :export* :import* :shadowing-import*
25.48+ :shadow* :make-symbol* :unintern*
25.49+ :symbol-shadowing-p :home-package-p
25.50+ :symbol-package-name :standard-common-lisp-symbol-p
25.51+ :reify-package :unreify-package :reify-symbol :unreify-symbol
25.52+ :nuke-symbol-in-package :nuke-symbol :rehome-symbol
25.53+ :ensure-package-unused :delete-package*
25.54+ :package-names :packages-from-names :fresh-package-name
25.55+ :rename-package-away :package-definition-form :parse-defpkg-form
25.56+ :ensure-package))
25.57+
25.58+(defpackage :std-user
25.59+ (:use :cl :std/named-readtables :std/defpkg)
25.60+ (:shadowing-import-from :std/defpkg :defpkg)
25.61+ (:export :defpkg :in-readtable))
25.62+
25.63+(in-package :std-user)
25.64+
25.65+(defpkg :std/err
25.66+ (:use :cl)
25.67+ (:export ;; err
25.68 :std-error :std-error-message
25.69 :define-error-reporter
25.70 :deferror
25.71@@ -35,7 +74,60 @@
25.72 :invalid-argument-item
25.73 :invalid-argument-reason
25.74 :invalid-argument-p
25.75- :unwind-protect-case
25.76+ :unwind-protect-case))
25.77+
25.78+(defpkg :std/sym
25.79+ (:use :cl)
25.80+ (:shadowing-import-from :sb-int
25.81+ :with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*
25.82+ :gensymify)
25.83+ (:export
25.84+ :ensure-symbol
25.85+ :format-symbol
25.86+ :make-keyword
25.87+ :make-slot-name
25.88+ :make-gensym
25.89+ :make-gensym-list
25.90+ :with-gensyms
25.91+ :with-unique-names
25.92+ :symbolicate
25.93+ :keywordicate
25.94+ :gensymify
25.95+ :gensymify*))
25.96+
25.97+(defpkg :std/list
25.98+ (:use :cl)
25.99+ (:shadowing-import-from :sb-int
25.100+ :ensure-list :recons :memq :assq
25.101+ :ensure-list :proper-list-of-length-p :proper-list-p :singleton-p)
25.102+ (:export
25.103+ :ensure-car
25.104+ :ensure-cons
25.105+ :appendf
25.106+ :nconcf
25.107+ :unionf
25.108+ :nunionf
25.109+ :reversef
25.110+ :nreversef
25.111+ :deletef
25.112+ :flatten
25.113+ :group
25.114+ :let-binding-transform
25.115+ :ensure-list :recons :memq :assq
25.116+ :circular-list :circular-list-p :circular-tree-p :merge!
25.117+ :sort!))
25.118+
25.119+(defpkg :std/type
25.120+ (:use :cl)
25.121+ (:import-from :std/sym :format-symbol)
25.122+ (:import-from :std/list :ensure-car)
25.123+ (:export :+default-element-type+
25.124+ :array-index :array-length
25.125+ :negative-integer :non-negative-integer :positive-integer))
25.126+
25.127+(defpkg :std/num
25.128+ (:use :cl)
25.129+ (:export
25.130 ;; num/parse
25.131 :parse-number
25.132 :parse-real-number
25.133@@ -48,7 +140,12 @@
25.134 :encode-float32
25.135 :decode-float32
25.136 :encode-float64
25.137- :decode-float64
25.138+ :decode-float64))
25.139+
25.140+(defpkg :std/stream
25.141+ (:use :cl)
25.142+ (:import-from :std/type :non-negative-integer :positive-integer)
25.143+ (:export
25.144 ;; stream
25.145 :copy-stream
25.146 :wrapped-stream
25.147@@ -58,66 +155,53 @@
25.148 :prefixed-character-output-stream
25.149 :stream-of :char-count-of :line-count-of :col-count-of
25.150 :prev-col-count-of :col-index-of :write-prefix
25.151- :prefix-of
25.152- ;; path
25.153- #:wild-pathname
25.154- #:non-wild-pathname
25.155- #:absolute-pathname
25.156- #:relative-pathname
25.157- #:directory-pathname
25.158- #:absolute-directory-pathname
25.159- ;; file
25.160- #:file-pathname
25.161- #:with-open-files
25.162- #:write-stream-into-file
25.163- #:write-file-into-stream
25.164- #:file=
25.165- #:file-size
25.166- :file-size-in-octets
25.167- :+pathsep+
25.168- :octet-vector=
25.169- :file-date
25.170- :file-timestamp
25.171- :directory-path-p
25.172- :hidden-path-p
25.173- :directory-path :find-files
25.174- :count-file-lines
25.175- ;; string
25.176- :*omit-nulls*
25.177- :*whitespaces*
25.178- :string-designator
25.179- :split
25.180- :trim
25.181- :collapse-whitespaces
25.182- :make-template-parser
25.183- :string-case
25.184- ;; fmt
25.185- :printer-status :fmt-row :format-sxhash :iprintln :fmt-tree :println
25.186- ;; sym
25.187- :ensure-symbol
25.188- :format-symbol
25.189- :make-keyword
25.190- :make-slot-name
25.191- :make-gensym
25.192- :make-gensym-list
25.193- :with-gensyms
25.194- :with-unique-names
25.195- :symbolicate
25.196- ;; list
25.197- :ensure-car
25.198- :ensure-cons
25.199- :appendf
25.200- :nconcf
25.201- :unionf
25.202- :nunionf
25.203- :reversef
25.204- :nreversef
25.205- :deletef
25.206- :let-binding-transform
25.207- :ensure-list :recons :memq :assq
25.208- :circular-list :circular-list-p :circular-tree-p
25.209- ;; :proper-list-of-length-p :proper-list-p :singleton-p
25.210- ;; thread
25.211+ :prefix-of))
25.212+
25.213+(defpkg :std/fu
25.214+ (:use :cl)
25.215+ (:export
25.216+ :ensure-function
25.217+ :ensure-functionf
25.218+ :disjoin
25.219+ :conjoin
25.220+ :compose
25.221+ :multiple-value-compose
25.222+ :curry
25.223+ :rcurry))
25.224+
25.225+(defpkg :std/array
25.226+ (:use :cl)
25.227+ (:export :copy-array :signed-array-length))
25.228+
25.229+(defpkg :std/hash-table
25.230+ (:use :cl)
25.231+ (:nicknames :std/ht)
25.232+ (:export :hash-table-alist
25.233+ :maphash-keys :hash-table-keys
25.234+ :maphash-values :hash-table-values))
25.235+
25.236+(defpkg :std/alien
25.237+ (:use :cl :sb-alien)
25.238+ (:import-from :std/sym :symbolicate)
25.239+ (:export
25.240+ :shared-object-name
25.241+ :define-alien-loader
25.242+ :c-string-to-string-list
25.243+ :list-all-shared-objects
25.244+ :num-cpus
25.245+ :*cpus*
25.246+ :loff-t
25.247+ :memset))
25.248+
25.249+(defpkg :std/mop
25.250+ (:use :cl)
25.251+ (:export :list-slot-values-using-class
25.252+ :list-class-methods :list-class-slots :list-indirect-slot-methods))
25.253+
25.254+(defpkg :std/thread
25.255+ (:use :cl :sb-thread :sb-concurrency)
25.256+ (:import-from :std/list :flatten)
25.257+ (:export
25.258 :print-thread-message-top-level :thread-support-p
25.259 :find-thread-by-id :thread-id-list
25.260 :make-threads :with-threads :finish-threads
25.261@@ -135,53 +219,15 @@
25.262 :job-tasks :make-job :job-p :task-object
25.263 :make-task :task-p :task :wait-for-threads
25.264 :task-pool-oracle :task-pool-jobs :task-pool-stages
25.265- :task-pool-workers :task-pool-results
25.266- ;; util
25.267- :find-package* #:find-symbol* #:symbol-call
25.268- :intern* #:export* #:import* #:shadowing-import*
25.269- :shadow* #:make-symbol* #:unintern*
25.270- :symbol-shadowing-p #:home-package-p
25.271- :symbol-package-name #:standard-common-lisp-symbol-p
25.272- :reify-package #:unreify-package #:reify-symbol #:unreify-symbol
25.273- :nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
25.274- :ensure-package-unused #:delete-package*
25.275- :package-names #:packages-from-names #:fresh-package-name
25.276- :rename-package-away #:package-definition-form #:parse-defpkg-form
25.277- :ensure-package :defpkg
25.278- :save-lisp-tree-shake-and-die
25.279- :save-lisp-and-live
25.280- ;; ana
25.281- :awhen
25.282- :acond
25.283- :alambda
25.284- :nlet-tail
25.285- :alet%
25.286- :alet
25.287- :acond2
25.288- :it
25.289- :aif
25.290- :this
25.291- :self
25.292- ;; pan
25.293- :pandoriclet
25.294- :pandoriclet-get
25.295- :pandoriclet-set
25.296- :get-pandoric
25.297- :with-pandoric
25.298- :pandoric-hotpatch
25.299- :pandoric-recode
25.300- :plambda
25.301- :pandoric-eval
25.302- ;; fu
25.303- :copy-array
25.304- :hash-table-alist
25.305- :until
25.306- :mkstr
25.307- :symb
25.308- :group
25.309- :flatten
25.310- :fact
25.311- :choose
25.312+ :task-pool-workers :task-pool-results))
25.313+
25.314+(defpkg :std/macs
25.315+ (:use :cl)
25.316+ (:import-from :std/sym :symb :mkstr :make-gensym-list :once-only)
25.317+ (:import-from :std/named-readtables :in-readtable :parse-body)
25.318+ (:import-from :std/list :flatten)
25.319+ (:export
25.320+ :named-lambda
25.321 :g!-symbol-p
25.322 :defmacro/g!
25.323 :o!-symbol-p
25.324@@ -189,6 +235,9 @@
25.325 :defmacro!
25.326 :defun!
25.327 :dlambda
25.328+ :until
25.329+ :fact
25.330+ :choose
25.331 :make-tlist
25.332 :tlist-left
25.333 :tlist-right
25.334@@ -214,38 +263,32 @@
25.335 :define-constant
25.336 :def!
25.337 :eval-always
25.338- :merge! :sort!
25.339- :list-slot-values-using-class :list-class-methods :list-class-slots :list-indirect-slot-methods
25.340- :signed-array-length
25.341- :take
25.342- :maphash-keys
25.343- :hash-table-keys
25.344- :maphash-values
25.345- :hash-table-values
25.346- :current-lisp-implementation
25.347- :tmpfile
25.348- :ensure-function
25.349- :ensure-functionf
25.350- :disjoin
25.351- :conjoin
25.352- :compose
25.353- :multiple-value-compose
25.354- :curry
25.355- :rcurry
25.356- :named-lambda
25.357- ;; alien
25.358- :shared-object-name
25.359- :define-alien-loader
25.360- :c-string-to-string-list
25.361- :list-all-shared-objects
25.362- :num-cpus
25.363- :*cpus*
25.364- :loff-t
25.365- :memset
25.366- ;; os
25.367- :list-all-users
25.368- :list-all-groups
25.369- ;; bits
25.370+ ;; ana
25.371+ :awhen
25.372+ :acond
25.373+ :alambda
25.374+ :nlet-tail
25.375+ :alet%
25.376+ :alet
25.377+ :acond2
25.378+ :it
25.379+ :aif
25.380+ :this
25.381+ :self
25.382+ ;; pan
25.383+ :pandoriclet
25.384+ :pandoriclet-get
25.385+ :pandoriclet-set
25.386+ :get-pandoric
25.387+ :with-pandoric
25.388+ :pandoric-hotpatch
25.389+ :pandoric-recode
25.390+ :plambda
25.391+ :pandoric-eval))
25.392+
25.393+(defpkg :std/bit
25.394+ (:use :cl)
25.395+ (:export
25.396 :make-bits
25.397 :sign-bit
25.398 :different-signs-p
25.399@@ -262,7 +305,9 @@
25.400 :clone-strings
25.401 :clone-octets-to-alien
25.402 :clone-octets-from-alien
25.403- :foreign-int-to-integer :foreign-int-to-bool :bool-to-foreign-int
25.404+ :foreign-int-to-integer
25.405+ :foreign-int-to-bool
25.406+ :bool-to-foreign-int
25.407 :bitfield
25.408 :bitfield-slot-name
25.409 :bitfield-slot-start
25.410@@ -283,7 +328,81 @@
25.411 :octet-vector-to-hex-string
25.412 :octets-to-integer
25.413 :integer-to-octets
25.414- :hexchar-to-int
25.415+ :hexchar-to-int))
25.416+
25.417+(defpkg :std/fmt
25.418+ (:use :cl)
25.419+ (:import-from :std/list :group :ensure-cons)
25.420+ (:shadowing-import-from :uiop :println)
25.421+ (:export :printer-status :fmt-row :format-sxhash :iprintln :fmt-tree :println))
25.422+
25.423+(defpkg :std/path
25.424+ (:use :cl)
25.425+ (:export
25.426+ :wild-pathname
25.427+ :non-wild-pathname
25.428+ :absolute-pathname
25.429+ :relative-pathname
25.430+ :directory-pathname
25.431+ :absolute-directory-pathname))
25.432+
25.433+(defpkg :std/os
25.434+ (:use :cl)
25.435+ (:export
25.436+ :list-all-users
25.437+ :list-all-groups))
25.438+
25.439+(defpkg :std/file
25.440+ (:use :cl)
25.441+ (:export
25.442+ :tmpfile
25.443+ :file-pathname
25.444+ :with-open-files
25.445+ :write-stream-into-file
25.446+ :write-file-into-stream
25.447+ :file=
25.448+ :file-size
25.449+ :file-size-in-octets
25.450+ :+pathsep+
25.451+ :octet-vector=
25.452+ :file-date
25.453+ :file-timestamp
25.454+ :directory-path-p
25.455+ :hidden-path-p
25.456+ :directory-path
25.457+ :find-files
25.458+ :count-file-lines))
25.459+
25.460+(defpkg :std/string
25.461+ (:use :cl)
25.462+ (:export
25.463+ :*omit-nulls*
25.464+ :*whitespaces*
25.465+ :string-designator
25.466+ :ssplit
25.467+ :trim
25.468+ :collapse-whitespaces
25.469+ :make-template-parser
25.470+ :string-case))
25.471+
25.472+(defpkg :std/seq
25.473+ (:use :cl)
25.474+ (:import-from :std/array :signed-array-length)
25.475+ (:export :take))
25.476+
25.477+(defpkg :std/sys
25.478+ (:use :cl)
25.479+ (:export
25.480+ :current-lisp-implementation
25.481+ :save-lisp-tree-shake-and-die
25.482+ :save-lisp-and-live))
25.483+
25.484+(defpkg :std/readtable
25.485+ (:use :cl)
25.486+ (:import-from :std/named-readtables :defreadtable)
25.487+ (:import-from :std/sym :symb)
25.488+ (:import-from :std/macs :defmacro!)
25.489+ (:export
25.490 ;; readtable
25.491 :|#"-reader|
25.492 :|#`-reader|
25.493@@ -295,5 +414,8 @@
25.494 :|#~-reader|
25.495 :_))
25.496
25.497-(defpackage :std-user
25.498- (:use :cl :cl-user :std))
25.499+(defpkg :std
25.500+ (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien :sb-gray :sb-concurrency)
25.501+ (:use-reexport :std/named-readtables :std/defpkg :std/err :std/sym :std/list :std/type :std/num
25.502+ :std/stream :std/fu :std/array :std/hash-table :std/alien :std/mop :std/thread
25.503+ :std/macs :std/bit :std/fmt :std/path :std/os :std/file :std/string :std/seq :std/sys :std/readtable))
26.1--- a/lisp/std/readtable.lisp Sun Apr 21 22:38:49 2024 -0400
26.2+++ b/lisp/std/readtable.lisp Mon Apr 22 23:14:47 2024 -0400
26.3@@ -6,7 +6,7 @@
26.4 ;;; Usage: (in-readtable :std)
26.5
26.6 ;;; Code:
26.7-(in-package :std)
26.8+(in-package :std/readtable)
26.9
26.10 (eval-when (:compile-toplevel :execute :load-toplevel)
26.11 (defun |#`-reader| (stream sub-char numarg)
27.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
27.2+++ b/lisp/std/seq.lisp Mon Apr 22 23:14:47 2024 -0400
27.3@@ -0,0 +1,24 @@
27.4+;;; std/seq.lisp --- Standard Sequences
27.5+
27.6+;;
27.7+
27.8+;;; Code:
27.9+(in-package :std/seq)
27.10+
27.11+(defun take (n seq)
27.12+ "Return, at most, the first N elements of SEQ, as a *new* sequence
27.13+of the same type as SEQ.
27.14+
27.15+If N is longer than SEQ, SEQ is simply copied.
27.16+
27.17+If N is negative, then |N| elements are taken (in their original
27.18+order) from the end of SEQ."
27.19+ #+sbcl (declare (sb-ext:muffle-conditions style-warning))
27.20+ (declare (type signed-array-length n))
27.21+ (seq-dispatch seq
27.22+ (if (minusp n)
27.23+ (last seq (abs n))
27.24+ (firstn n seq))
27.25+ (if (minusp n)
27.26+ (subseq seq (max 0 (+ (length seq) n)))
27.27+ (subseq seq 0 (min n (length seq))))))
28.1--- a/lisp/std/std.asd Sun Apr 21 22:38:49 2024 -0400
28.2+++ b/lisp/std/std.asd Mon Apr 22 23:14:47 2024 -0400
28.3@@ -1,7 +1,7 @@
28.4 ;;; std.asd --- standard library
28.5 (defsystem :std/named-readtables
28.6 :version "0.1.0"
28.7- :components ((:file "named-readtables"))
28.8+ :components ((:file "pkg") (:file "named-readtables"))
28.9 :in-order-to ((test-op (test-op "std/tests"))))
28.10
28.11 (register-system-packages "std/named-readtables" '(:std))
28.12@@ -11,27 +11,38 @@
28.13 :depends-on (:std/named-readtables :cl-ppcre :sb-concurrency)
28.14 :serial t
28.15 :components ((:file "pkg")
28.16+ (:file "defpkg")
28.17 (:file "err")
28.18- (:file "bits")
28.19- (:module "num"
28.20- :components ((:file "float")
28.21- (:file "parse")))
28.22- (:file "string")
28.23- (:file "fmt")
28.24 (:file "sym")
28.25 (:file "list")
28.26- (:file "util")
28.27- (:file "readtable")
28.28- (:file "ana")
28.29- (:file "pan")
28.30- (:file "fu")
28.31- (:file "types")
28.32+ (:file "type")
28.33+ (:module "num"
28.34+ :components
28.35+ ((:file "float")
28.36+ (:file "parse")))
28.37+ (:file "stream")
28.38+ (:module "fu"
28.39+ :components
28.40+ ((:file "curry")))
28.41+ (:file "array")
28.42+ (:file "hash-table")
28.43+ (:file "alien")
28.44+ (:file "mop")
28.45+ (:file "thread")
28.46+ (:module "macs"
28.47+ :components
28.48+ ((:file "ana")
28.49+ (:file "pan")
28.50+ (:file "const")))
28.51+ (:file "bit")
28.52+ (:file "fmt")
28.53 (:file "path")
28.54- (:file "stream")
28.55+ (:file "os")
28.56 (:file "file")
28.57- (:file "thread")
28.58- (:file "defpkg")
28.59- (:file "alien"))
28.60+ (:file "string")
28.61+ (:file "seq")
28.62+ (:file "sys")
28.63+ (:file "readtable"))
28.64 :in-order-to ((test-op (test-op "std/tests"))))
28.65
28.66 (register-system-packages "std" '(:std))
29.1--- a/lisp/std/stream.lisp Sun Apr 21 22:38:49 2024 -0400
29.2+++ b/lisp/std/stream.lisp Mon Apr 22 23:14:47 2024 -0400
29.3@@ -3,7 +3,7 @@
29.4 ;;
29.5
29.6 ;;; Code:
29.7-(in-package :std)
29.8+(in-package :std/stream)
29.9
29.10 (defun copy-stream (input output &key (element-type (stream-element-type input))
29.11 (buffer-size 4096)
30.1--- a/lisp/std/string.lisp Sun Apr 21 22:38:49 2024 -0400
30.2+++ b/lisp/std/string.lisp Mon Apr 22 23:14:47 2024 -0400
30.3@@ -13,7 +13,7 @@
30.4 ;; decimal-value digit-value
30.5 ;; unicode< unicode> unicode= unicode-equal
30.6 ;; unicode<= unicode>=))
30.7-(in-package :std)
30.8+(in-package :std/string)
30.9
30.10 ;; (mapc (lambda (s) (export s)) sb-unicode-syms)
30.11 ;; (reexport-from
31.1--- a/lisp/std/sym.lisp Sun Apr 21 22:38:49 2024 -0400
31.2+++ b/lisp/std/sym.lisp Mon Apr 22 23:14:47 2024 -0400
31.3@@ -3,7 +3,7 @@
31.4 ;; inspired by alexandria/symbols.lisp
31.5
31.6 ;;; Code:
31.7-(in-package :std)
31.8+(in-package :std/sym)
31.9
31.10 ;;(std::reexport-from
31.11 ;; :sb-int
31.12@@ -12,7 +12,8 @@
31.13 ;; On SBCL, `with-unique-names' is defined under
31.14 ;; src/code/primordial-extensions.lisp. We use that instead of
31.15 ;; defining our own.
31.16-(setf (macro-function 'with-gensyms) (macro-function 'with-unique-names))
31.17+(eval-when (:compile-toplevel :load-toplevel :execute)
31.18+ (setf (macro-function 'with-gensyms) (macro-function 'with-unique-names)))
31.19
31.20 (declaim (inline ensure-symbol))
31.21 (defun ensure-symbol (name &optional (package *package*))
31.22@@ -69,26 +70,6 @@
31.23 (defun symb (&rest args)
31.24 (values (intern (apply #'mkstr args))))
31.25
31.26-(defun g!-symbol-p (s)
31.27- (and (symbolp s)
31.28- (> (length (symbol-name s)) 2)
31.29- (string= (symbol-name s)
31.30- "G!"
31.31- :start1 0
31.32- :end1 2)))
31.33-
31.34-(defun o!-symbol-p (s)
31.35- (and (symbolp s)
31.36- (> (length (symbol-name s)) 2)
31.37- (string= (symbol-name s)
31.38- "O!"
31.39- :start1 0
31.40- :end1 2)))
31.41-
31.42-(defun o!-symbol-to-g!-symbol (s)
31.43- (symb "G!"
31.44- (subseq (symbol-name s) 2)))
31.45-
31.46 (sb-ext:with-unlocked-packages (:sb-int)
31.47 (handler-bind
31.48 ((sb-kernel:redefinition-warning #'muffle-warning))
32.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
32.2+++ b/lisp/std/sys.lisp Mon Apr 22 23:14:47 2024 -0400
32.3@@ -0,0 +1,56 @@
32.4+;;; std/sys.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*-
32.5+
32.6+;;
32.7+
32.8+;;; Code:
32.9+(in-package :std/sys)
32.10+
32.11+;;; Introspection
32.12+;; (reexport-from :sb-introspect
32.13+;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit
32.14+;; :method-combination-lambda-list :deftype-lambda-list
32.15+;; :primitive-object-size :allocation-information
32.16+;; :function-type
32.17+;; :who-specializes-directly :who-specializes-generally
32.18+;; :find-function-callees :find-function-callers))
32.19+
32.20+(defun current-lisp-implementation ()
32.21+ "Return the current lisp implemenation as a cons: (TYPE VERSION)"
32.22+ (list
32.23+ (lisp-implementation-type)
32.24+ (lisp-implementation-version)
32.25+ *features*))
32.26+
32.27+;; TODO
32.28+(defun save-lisp-tree-shake-and-die (path &rest args)
32.29+ "A naive tree-shaker for lisp."
32.30+ (sb-ext:gc :full t)
32.31+ (apply #'sb-ext:save-lisp-and-die path args))
32.32+
32.33+(defun save-lisp-and-live (filename completion-function restart &rest args)
32.34+ (flet ((restart-sbcl ()
32.35+ (sb-debug::enable-debugger)
32.36+ (setf sb-impl::*descriptor-handlers* nil)
32.37+ (funcall restart)))
32.38+ ;; fork it - assumes only one thread is running
32.39+ (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
32.40+ (let ((pid (sb-posix:fork)))
32.41+ (cond ((= pid 0) ;; make simple-restart core
32.42+ (sb-posix:close pipe-in)
32.43+ (sb-debug::disable-debugger)
32.44+ (apply #'sb-ext:save-lisp-and-die filename
32.45+ (append
32.46+ (list :toplevel #'restart-sbcl)
32.47+ args)))
32.48+ (t
32.49+ (sb-posix:close pipe-out)
32.50+ (sb-sys:add-fd-handler
32.51+ pipe-in :input
32.52+ (lambda (fd)
32.53+ (sb-sys:invalidate-descriptor fd)
32.54+ (sb-posix:close fd)
32.55+ (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master
32.56+ (assert (= pid rpid))
32.57+ (assert (sb-posix:wifexited status))
32.58+ (funcall completion-function
32.59+ (zerop (sb-posix:wexitstatus status))))))))))))
33.1--- a/lisp/std/thread.lisp Sun Apr 21 22:38:49 2024 -0400
33.2+++ b/lisp/std/thread.lisp Mon Apr 22 23:14:47 2024 -0400
33.3@@ -7,7 +7,7 @@
33.4 ;; mostly yoinked from sb-thread and friends
33.5
33.6 ;;; Code:
33.7-(in-package :std)
33.8+(in-package :std/thread)
33.9
33.10 ;; (sb-thread:thread-os-tid sb-thread:*current-thread*)
33.11 ;; sb-thread:interrupt-thread
33.12@@ -203,26 +203,41 @@
33.13 (declare (ignore pool))
33.14 (make-threads count function :name *default-worker-name*)))
33.15
33.16-(defmacro define-task-kernel (name (&rest opts) &body body)
33.17- "Define a kernel function for tasks."
33.18- `(defun ,name (,@opts)
33.19+(defmacro define-task-kernel (name (&key args accessors) &body body)
33.20+ "Define a task kernel.
33.21+
33.22+(define-task-kernel NAME (&key ARGS MAX MIN ACCESSORS)
33.23+
33.24+The kernel should process all options and return a function - the
33.25+'kernel function'.
33.26+
33.27+The kernel function is installed in worker threads by passing it to
33.28+SB-THREAD:MAKE-THREAD. It may accept a varying number of arguments
33.29+specified by ARGS.
33.30+
33.31+ACCESSORS is a list of pandoric accessors which can be called on the
33.32+kernel via an ORACLE.
33.33+
33.34+This interface is experimental and subject to change."
33.35+ `(defun ,name (,@args)
33.36 ,@body))
33.37
33.38-(define-task-kernel default-task-kernel ()
33.39+(define-task-kernel default-task-kernel (:args () )
33.40 "The default task kernel used to initialize the KERNEL slot of
33.41-task-pools. Currently, the kernel is used to initialize every worker
33.42-in the pool when it is spawned starts running immediately."
33.43+task-pools.
33.44+
33.45+"
33.46 nil)
33.47
33.48 (defgeneric spawn-worker (pool)
33.49 (:method ((pool null))
33.50 (declare (ignore pool))
33.51- (make-thread *default-task-kernel*)))
33.52+ (make-thread (default-task-kernel))))
33.53
33.54 (defgeneric spawn-workers (pool count)
33.55 (:method ((pool null) (count fixnum))
33.56 (declare (ignore pool))
33.57- (make-threads count *default-task-kernel* :name *default-worker-name*)))
33.58+ (make-threads count (default-task-kernel) :name *default-worker-name*)))
33.59
33.60 (defstruct task-pool
33.61 (oracle-id nil :type (or null (unsigned-byte 32)))
33.62@@ -325,7 +340,7 @@
33.63
33.64 ;; TODO..
33.65 (defmethod run-job ((self task-pool) (job job))
33.66- (log:trace! "running remote job...")
33.67+ #+log (log:trace! "running remote job...")
33.68 (push-job job self))
33.69
33.70 (defclass stage ()
34.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
34.2+++ b/lisp/std/type.lisp Mon Apr 22 23:14:47 2024 -0400
34.3@@ -0,0 +1,157 @@
34.4+;;; std/types.lisp --- Standard Types
34.5+
34.6+;;
34.7+
34.8+;;; Code:
34.9+(in-package :std/type)
34.10+
34.11+(defconstant +default-element-type+ 'character)
34.12+
34.13+(deftype array-index (&optional (length (1- array-dimension-limit)))
34.14+ "Type designator for an index into array of LENGTH: an integer between
34.15+0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
34.16+ARRAY-DIMENSION-LIMIT."
34.17+ `(integer 0 (,length)))
34.18+
34.19+(deftype array-length (&optional (length (1- array-dimension-limit)))
34.20+ "Type designator for a dimension of an array of LENGTH: an integer between
34.21+0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
34.22+ARRAY-DIMENSION-LIMIT."
34.23+ `(integer 0 ,length))
34.24+
34.25+;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
34.26+;; except the RATIO related definitions and ARRAY-INDEX.
34.27+(macrolet
34.28+ ((frob (type &optional (base-type type))
34.29+ (let ((subtype-names (list))
34.30+ (predicate-names (list)))
34.31+ (flet ((make-subtype-name (format-control)
34.32+ (let ((result (format-symbol :std format-control
34.33+ (symbol-name type))))
34.34+ (push result subtype-names)
34.35+ result))
34.36+ (make-predicate-name (sybtype-name)
34.37+ (let ((result (format-symbol :std '#:~A-p
34.38+ (symbol-name sybtype-name))))
34.39+ (push result predicate-names)
34.40+ result))
34.41+ (make-docstring (range-beg range-end range-type)
34.42+ (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
34.43+ (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
34.44+ type
34.45+ (if (equal range-beg ''*) inf (ensure-car range-beg))
34.46+ (if (equal range-end ''*) inf (ensure-car range-end))))))
34.47+ (let* ((negative-name (make-subtype-name '#:negative-~a))
34.48+ (non-positive-name (make-subtype-name '#:non-positive-~a))
34.49+ (non-negative-name (make-subtype-name '#:non-negative-~a))
34.50+ (positive-name (make-subtype-name '#:positive-~a))
34.51+ (negative-p-name (make-predicate-name negative-name))
34.52+ (non-positive-p-name (make-predicate-name non-positive-name))
34.53+ (non-negative-p-name (make-predicate-name non-negative-name))
34.54+ (positive-p-name (make-predicate-name positive-name))
34.55+ (negative-extremum)
34.56+ (positive-extremum)
34.57+ (below-zero)
34.58+ (above-zero)
34.59+ (zero))
34.60+ (setf (values negative-extremum below-zero
34.61+ above-zero positive-extremum zero)
34.62+ (ecase type
34.63+ (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
34.64+ (integer (values ''* -1 1 ''* 0))
34.65+ (rational (values ''* '(0) '(0) ''* 0))
34.66+ (real (values ''* '(0) '(0) ''* 0))
34.67+ (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
34.68+ (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
34.69+ (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
34.70+ (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
34.71+ (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
34.72+ `(progn
34.73+ (deftype ,negative-name ()
34.74+ ,(make-docstring negative-extremum below-zero :negative)
34.75+ `(,',base-type ,,negative-extremum ,',below-zero))
34.76+
34.77+ (deftype ,non-positive-name ()
34.78+ ,(make-docstring negative-extremum zero :negative)
34.79+ `(,',base-type ,,negative-extremum ,',zero))
34.80+
34.81+ (deftype ,non-negative-name ()
34.82+ ,(make-docstring zero positive-extremum :positive)
34.83+ `(,',base-type ,',zero ,,positive-extremum))
34.84+
34.85+ (deftype ,positive-name ()
34.86+ ,(make-docstring above-zero positive-extremum :positive)
34.87+ `(,',base-type ,',above-zero ,,positive-extremum))
34.88+
34.89+ (declaim (inline ,@predicate-names))
34.90+
34.91+ (defun ,negative-p-name (n)
34.92+ (and (typep n ',type)
34.93+ (< n ,zero)))
34.94+
34.95+ (defun ,non-positive-p-name (n)
34.96+ (and (typep n ',type)
34.97+ (<= n ,zero)))
34.98+
34.99+ (defun ,non-negative-p-name (n)
34.100+ (and (typep n ',type)
34.101+ (<= ,zero n)))
34.102+
34.103+ (defun ,positive-p-name (n)
34.104+ (and (typep n ',type)
34.105+ (< ,zero n)))))))))
34.106+ (frob fixnum integer)
34.107+ (frob integer)
34.108+ (frob rational)
34.109+ (frob real)
34.110+ (frob float)
34.111+ (frob short-float)
34.112+ (frob single-float)
34.113+ (frob double-float)
34.114+ (frob long-float))
34.115+
34.116+(defun of-type (type)
34.117+ "Returns a function of one argument, which returns true when its argument is
34.118+of TYPE."
34.119+ (lambda (thing) (typep thing type)))
34.120+
34.121+(define-compiler-macro of-type (&whole form type &environment env)
34.122+ ;; This can yeild a big benefit, but no point inlining the function
34.123+ ;; all over the place if TYPE is not constant.
34.124+ (if (constantp type env)
34.125+ (with-gensyms (thing)
34.126+ `(lambda (,thing)
34.127+ (typep ,thing ,type)))
34.128+ form))
34.129+
34.130+(declaim (inline type=))
34.131+(defun type= (type1 type2)
34.132+ "Returns a primary value of T if TYPE1 and TYPE2 are the same type,
34.133+and a secondary value that is true is the type equality could be reliably
34.134+determined: primary value of NIL and secondary value of T indicates that the
34.135+types are not equivalent."
34.136+ (multiple-value-bind (sub ok) (subtypep type1 type2)
34.137+ (cond ((and ok sub) ; type1 is known to be a subtype of type 2
34.138+ ; so type= return values come from the second invocation of subtypep
34.139+ (subtypep type2 type1))
34.140+ ;; type1 is assuredly NOT a subtype of type2,
34.141+ ;; so assuredly type1 and type2 cannot be type=
34.142+ (ok
34.143+ (values nil t))
34.144+ ;; our first result is uncertain ( ok == nil ) and it follows
34.145+ ;; from specification of SUBTYPEP that sub = ok = NIL
34.146+ (t
34.147+ (assert (not sub)) ; is the implementation correct?
34.148+ (multiple-value-bind (sub2 ok2)
34.149+ (subtypep type2 type1)
34.150+ (if (and (not sub2) ok2) ; we KNOW type2 is not a subtype of type1
34.151+ ;; so our results are certain...
34.152+ (values nil t)
34.153+ ;; otherwise, either type2 is surely a subtype of type1 (t t)
34.154+ ;; or type2 is not a subtype of type1, but we don't
34.155+ ;; know that for sure (nil nil)
34.156+ ;; In either case our result is negative but unsure
34.157+ (values nil nil)))))))
34.158+
34.159+(define-modify-macro coercef (type-spec) coerce
34.160+ "Modify-macro for COERCE.")
35.1--- a/lisp/std/types.lisp Sun Apr 21 22:38:49 2024 -0400
35.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
35.3@@ -1,157 +0,0 @@
35.4-;;; std/types.lisp --- Standard Types
35.5-
35.6-;;
35.7-
35.8-;;; Code:
35.9-(in-package :std)
35.10-
35.11-(defconstant +default-element-type+ 'character)
35.12-
35.13-(deftype array-index (&optional (length (1- array-dimension-limit)))
35.14- "Type designator for an index into array of LENGTH: an integer between
35.15-0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
35.16-ARRAY-DIMENSION-LIMIT."
35.17- `(integer 0 (,length)))
35.18-
35.19-(deftype array-length (&optional (length (1- array-dimension-limit)))
35.20- "Type designator for a dimension of an array of LENGTH: an integer between
35.21-0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
35.22-ARRAY-DIMENSION-LIMIT."
35.23- `(integer 0 ,length))
35.24-
35.25-;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
35.26-;; except the RATIO related definitions and ARRAY-INDEX.
35.27-(macrolet
35.28- ((frob (type &optional (base-type type))
35.29- (let ((subtype-names (list))
35.30- (predicate-names (list)))
35.31- (flet ((make-subtype-name (format-control)
35.32- (let ((result (format-symbol :std format-control
35.33- (symbol-name type))))
35.34- (push result subtype-names)
35.35- result))
35.36- (make-predicate-name (sybtype-name)
35.37- (let ((result (format-symbol :std '#:~A-p
35.38- (symbol-name sybtype-name))))
35.39- (push result predicate-names)
35.40- result))
35.41- (make-docstring (range-beg range-end range-type)
35.42- (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
35.43- (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
35.44- type
35.45- (if (equal range-beg ''*) inf (ensure-car range-beg))
35.46- (if (equal range-end ''*) inf (ensure-car range-end))))))
35.47- (let* ((negative-name (make-subtype-name '#:negative-~a))
35.48- (non-positive-name (make-subtype-name '#:non-positive-~a))
35.49- (non-negative-name (make-subtype-name '#:non-negative-~a))
35.50- (positive-name (make-subtype-name '#:positive-~a))
35.51- (negative-p-name (make-predicate-name negative-name))
35.52- (non-positive-p-name (make-predicate-name non-positive-name))
35.53- (non-negative-p-name (make-predicate-name non-negative-name))
35.54- (positive-p-name (make-predicate-name positive-name))
35.55- (negative-extremum)
35.56- (positive-extremum)
35.57- (below-zero)
35.58- (above-zero)
35.59- (zero))
35.60- (setf (values negative-extremum below-zero
35.61- above-zero positive-extremum zero)
35.62- (ecase type
35.63- (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
35.64- (integer (values ''* -1 1 ''* 0))
35.65- (rational (values ''* '(0) '(0) ''* 0))
35.66- (real (values ''* '(0) '(0) ''* 0))
35.67- (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
35.68- (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
35.69- (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
35.70- (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
35.71- (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
35.72- `(progn
35.73- (deftype ,negative-name ()
35.74- ,(make-docstring negative-extremum below-zero :negative)
35.75- `(,',base-type ,,negative-extremum ,',below-zero))
35.76-
35.77- (deftype ,non-positive-name ()
35.78- ,(make-docstring negative-extremum zero :negative)
35.79- `(,',base-type ,,negative-extremum ,',zero))
35.80-
35.81- (deftype ,non-negative-name ()
35.82- ,(make-docstring zero positive-extremum :positive)
35.83- `(,',base-type ,',zero ,,positive-extremum))
35.84-
35.85- (deftype ,positive-name ()
35.86- ,(make-docstring above-zero positive-extremum :positive)
35.87- `(,',base-type ,',above-zero ,,positive-extremum))
35.88-
35.89- (declaim (inline ,@predicate-names))
35.90-
35.91- (defun ,negative-p-name (n)
35.92- (and (typep n ',type)
35.93- (< n ,zero)))
35.94-
35.95- (defun ,non-positive-p-name (n)
35.96- (and (typep n ',type)
35.97- (<= n ,zero)))
35.98-
35.99- (defun ,non-negative-p-name (n)
35.100- (and (typep n ',type)
35.101- (<= ,zero n)))
35.102-
35.103- (defun ,positive-p-name (n)
35.104- (and (typep n ',type)
35.105- (< ,zero n)))))))))
35.106- (frob fixnum integer)
35.107- (frob integer)
35.108- (frob rational)
35.109- (frob real)
35.110- (frob float)
35.111- (frob short-float)
35.112- (frob single-float)
35.113- (frob double-float)
35.114- (frob long-float))
35.115-
35.116-(defun of-type (type)
35.117- "Returns a function of one argument, which returns true when its argument is
35.118-of TYPE."
35.119- (lambda (thing) (typep thing type)))
35.120-
35.121-(define-compiler-macro of-type (&whole form type &environment env)
35.122- ;; This can yeild a big benefit, but no point inlining the function
35.123- ;; all over the place if TYPE is not constant.
35.124- (if (constantp type env)
35.125- (with-gensyms (thing)
35.126- `(lambda (,thing)
35.127- (typep ,thing ,type)))
35.128- form))
35.129-
35.130-(declaim (inline type=))
35.131-(defun type= (type1 type2)
35.132- "Returns a primary value of T if TYPE1 and TYPE2 are the same type,
35.133-and a secondary value that is true is the type equality could be reliably
35.134-determined: primary value of NIL and secondary value of T indicates that the
35.135-types are not equivalent."
35.136- (multiple-value-bind (sub ok) (subtypep type1 type2)
35.137- (cond ((and ok sub) ; type1 is known to be a subtype of type 2
35.138- ; so type= return values come from the second invocation of subtypep
35.139- (subtypep type2 type1))
35.140- ;; type1 is assuredly NOT a subtype of type2,
35.141- ;; so assuredly type1 and type2 cannot be type=
35.142- (ok
35.143- (values nil t))
35.144- ;; our first result is uncertain ( ok == nil ) and it follows
35.145- ;; from specification of SUBTYPEP that sub = ok = NIL
35.146- (t
35.147- (assert (not sub)) ; is the implementation correct?
35.148- (multiple-value-bind (sub2 ok2)
35.149- (subtypep type2 type1)
35.150- (if (and (not sub2) ok2) ; we KNOW type2 is not a subtype of type1
35.151- ;; so our results are certain...
35.152- (values nil t)
35.153- ;; otherwise, either type2 is surely a subtype of type1 (t t)
35.154- ;; or type2 is not a subtype of type1, but we don't
35.155- ;; know that for sure (nil nil)
35.156- ;; In either case our result is negative but unsure
35.157- (values nil nil)))))))
35.158-
35.159-(define-modify-macro coercef (type-spec) coerce
35.160- "Modify-macro for COERCE.")
36.1--- a/lisp/std/util.lisp Sun Apr 21 22:38:49 2024 -0400
36.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
36.3@@ -1,167 +0,0 @@
36.4-;;; std/util.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*-
36.5-;;; Code:
36.6-(in-package :std)
36.7-
36.8-;;; Misc
36.9-(defmacro until (condition &body body)
36.10- (let ((block-name (gensym)))
36.11- `(block ,block-name
36.12- (loop
36.13- (if ,condition
36.14- (return-from ,block-name nil)
36.15- (progn ,@body))))))
36.16-
36.17-(defmacro defmacro/g! (name args &rest body)
36.18- (let ((syms (remove-duplicates
36.19- (remove-if-not #'g!-symbol-p
36.20- (flatten body)))))
36.21- (multiple-value-bind (body declarations docstring)
36.22- (parse-body body :documentation t)
36.23- `(defmacro ,name ,args
36.24- ,@(when docstring
36.25- (list docstring))
36.26- ,@declarations
36.27- (let ,(mapcar
36.28- (lambda (s)
36.29- `(,s (gensym ,(subseq
36.30- (symbol-name s)
36.31- 2))))
36.32- syms)
36.33- ,@body)))))
36.34-
36.35-(defmacro defmacro! (name args &rest body)
36.36- (let* ((os (remove-if-not #'o!-symbol-p (flatten args)))
36.37- (gs (mapcar #'o!-symbol-to-g!-symbol os)))
36.38- (multiple-value-bind (body declarations docstring)
36.39- (parse-body body :documentation t)
36.40- `(defmacro/g! ,name ,args
36.41- ,@(when docstring
36.42- (list docstring))
36.43- ,@declarations
36.44- `(let ,(mapcar #'list (list ,@gs) (list ,@os))
36.45- ,(progn ,@body))))))
36.46-
36.47-(defmacro defun! (name args &body body)
36.48- (let ((syms (remove-duplicates
36.49- (remove-if-not #'g!-symbol-p
36.50- (flatten body)))))
36.51- (multiple-value-bind (body declarations docstring)
36.52- (parse-body body :documentation t)
36.53- `(defun ,name ,args
36.54- ,@(when docstring
36.55- (list docstring))
36.56- ,@declarations
36.57- (let ,(mapcar (lambda (s)
36.58- `(,s (gensym ,(subseq (symbol-name s)
36.59- 2))))
36.60- syms)
36.61- ,@body)))))
36.62-
36.63-(defmacro! dlambda (&rest ds)
36.64- "Dynamic dispatch lambda."
36.65- `(lambda (&rest ,g!args)
36.66- (case (car ,g!args)
36.67- ,@(mapcar
36.68- (lambda (d)
36.69- `(,(if (eq t (car d))
36.70- t
36.71- (list (car d)))
36.72- (apply (lambda ,@(cdr d))
36.73- ,(if (eq t (car d))
36.74- g!args
36.75- `(cdr ,g!args)))))
36.76- ds))))
36.77-
36.78-;; LoL tlist
36.79-;; (declaim (inline make-tlist tlist-left
36.80-;; tlist-right tlist-empty-p))
36.81-
36.82-;; (defun make-tlist () (cons nil nil))
36.83-;; (defun tlist-left (tl) (caar tl))
36.84-;; (defun tlist-right (tl) (cadr tl))
36.85-;; (defun tlist-empty-p (tl) (null (car tl)))
36.86-
36.87-;; (declaim (inline tlist-add-left
36.88-;; tlist-add-right))
36.89-
36.90-;; (defun tlist-add-left (tl it)
36.91-;; (let ((x (cons it (car tl))))
36.92-;; (if (tlist-empty-p tl)
36.93-;; (setf (cdr tl) x))
36.94-;; (setf (car tl) x)))
36.95-
36.96-;; (defun tlist-add-right (tl it)
36.97-;; (let ((x (cons it nil)))
36.98-;; (if (tlist-empty-p tl)
36.99-;; (setf (car tl) x)
36.100-;; (setf (cddr tl) x))
36.101-;; (setf (cdr tl) x)))
36.102-
36.103-;; (declaim (inline tlist-rem-left))
36.104-
36.105-;; (defun tlist-rem-left (tl)
36.106-;; (if (tlist-empty-p tl)
36.107-;; (error "Remove from empty tlist")
36.108-;; (let ((x (car tl)))
36.109-;; (setf (car tl) (cdar tl))
36.110-;; (if (tlist-empty-p tl)
36.111-;; (setf (cdr tl) nil)) ;; For gc
36.112-;; (car x))))
36.113-
36.114-;; (declaim (inline tlist-update))
36.115-
36.116-;; (defun tlist-update (tl)
36.117-;; (setf (cdr tl) (last (car tl))))
36.118-
36.119-(defun build-batcher-sn (n)
36.120- (let* (network
36.121- (tee (ceiling (log n 2)))
36.122- (p (ash 1 (- tee 1))))
36.123- (loop while (> p 0) do
36.124- (let ((q (ash 1 (- tee 1)))
36.125- (r 0)
36.126- (d p))
36.127- (loop while (> d 0) do
36.128- (loop for i from 0 to (- n d 1) do
36.129- (if (= (logand i p) r)
36.130- (push (list i (+ i d))
36.131- network)))
36.132- (setf d (- q p)
36.133- q (ash q -1)
36.134- r p)))
36.135- (setf p (ash p -1)))
36.136- (nreverse network)))
36.137-
36.138-;; TODO
36.139-(defun save-lisp-tree-shake-and-die (path &rest args)
36.140- "A naive tree-shaker for lisp."
36.141- (sb-ext:gc :full t)
36.142- (apply #'sb-ext:save-lisp-and-die path args))
36.143-
36.144-(defun save-lisp-and-live (filename completion-function restart &rest args)
36.145- (flet ((restart-sbcl ()
36.146- (sb-debug::enable-debugger)
36.147- (setf sb-impl::*descriptor-handlers* nil)
36.148- (funcall restart)))
36.149- ;; fork it - assumes only one thread is running
36.150- (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
36.151- (let ((pid (sb-posix:fork)))
36.152- (cond ((= pid 0) ;; make simple-restart core
36.153- (sb-posix:close pipe-in)
36.154- (sb-debug::disable-debugger)
36.155- (apply #'sb-ext:save-lisp-and-die filename
36.156- (append
36.157- (list :toplevel #'restart-sbcl)
36.158- args)))
36.159- (t
36.160- (sb-posix:close pipe-out)
36.161- (sb-sys:add-fd-handler
36.162- pipe-in :input
36.163- (lambda (fd)
36.164- (sb-sys:invalidate-descriptor fd)
36.165- (sb-posix:close fd)
36.166- (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master
36.167- (assert (= pid rpid))
36.168- (assert (sb-posix:wifexited status))
36.169- (funcall completion-function
36.170- (zerop (sb-posix:wexitstatus status))))))))))))
