# HG changeset patch # User Richard Westhaver # Date 1713842087 14400 # Node ID a0dfde3cb3c4311939d649cb799b9dd2e8040138 # Parent 14b0ee8d09c131116c0cd656848318f215328fc2 begin :STD refactor diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/ffi/uring/util.lisp --- a/lisp/ffi/uring/util.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/ffi/uring/util.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -60,3 +60,10 @@ ;; do-mmap ;; map len bytes starting from offset from file-descriptor in mmapped-region + +;;; CPU Affinity +;; it appears this actually crashes SBCL, receiving sig6 from foreign thread +;; (define-alien-routine sched-setaffinity int (pid int) (cpusetsize size-t) (set (* (struct cpu-set-t)))) +;; (define-alien-routine sched-getaffinity int (pid int) (cpusetsize size-t) (set (* (struct cpu-set-t)))) +;; (sched-getaffinity 0 cpu-setsize (make-alien (struct cpu-set-t))) +;; (sched-setaffinity 0 cpu-setsize (make-alien (struct cpu-set-t))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/alien.lisp --- a/lisp/std/alien.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/alien.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -21,7 +21,7 @@ ;; represented by objects of type ALIEN-VALUE. ;;; Code: -(in-package :std) +(in-package :std/alien) (shadowing-import '(sb-unix::syscall sb-unix::syscall* sb-unix::int-syscall sb-unix::with-restarted-syscall sb-unix::void-syscall) :std) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/ana.lisp --- a/lisp/std/ana.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -;;; ana.lisp --- anaphoric macros - -;;; Code: -(in-package :std) - -(in-readtable :std) - -;; Graham's alambda -(defmacro alambda (parms &body body) - `(labels ((self ,parms ,@body)) - #'self)) - -;; Graham's aif -(defmacro aif (test then &optional else) - `(let ((it ,test)) - (if it ,then ,else))) - -;; ;; TODO 2023-09-05: wrap, document, optimize, hack -;; re-exported from SB-INT -(defmacro awhen (test &body body) - `(let ((it ,test)) - (when it ,@body))) - -(defmacro acond (&rest clauses) - (if (null clauses) - `() - (destructuring-bind ((test &body body) &rest rest) clauses - (let ((it (copy-symbol 'it))) - `(let ((,it ,test)) - (if ,it - ;; Just like COND - no body means return the tested value. - ,(if body - `(let ((it ,it)) (declare (ignorable it)) ,@body) - it) - (acond ,@rest))))))) - -(defmacro! nlet-tail (n letargs &body body) - (let ((gs (loop for i in letargs - collect (gensym)))) - `(macrolet - ((,n ,gs - `(progn - (psetq - ,@(apply #'nconc - (mapcar - #'list - ',(mapcar #'car letargs) - (list ,@gs)))) - (go ,',g!n)))) - (block ,g!b - (let ,letargs - (tagbody - ,g!n (return-from - ,g!b (progn ,@body)))))))) - -(defmacro alet% (letargs &rest body) - `(let ((this) ,@letargs) - (setq this ,@(last body)) - ,@(butlast body) - this)) - -(defmacro alet (letargs &rest body) - `(let ((this) ,@letargs) - (setq this ,@(last body)) - ,@(butlast body) - (lambda (&rest params) - (apply this params)))) - -;; swiped from fiveam. This is just like acond except it assumes that -;; the TEST in each element of CLAUSES returns two values as opposed -;; to one. -(defmacro acond2 (&rest clauses) - (if (null clauses) - nil - (with-gensyms (val foundp) - (destructuring-bind ((test &rest progn) &rest others) - clauses - `(multiple-value-bind (,val ,foundp) - ,test - (if (or ,val ,foundp) - (let ((it ,val)) - (declare (ignorable it)) - ,@progn) - (acond2 ,@others))))))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/array.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/array.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,24 @@ +;;; std/array.lisp --- Standard Arrays + +;; + +;;; Code: +(in-package :std/array) + +(defun copy-array (array) + (let ((new-array + (make-array (array-dimensions array) + :element-type (array-element-type array) + :adjustable (adjustable-array-p array) + :fill-pointer (and (array-has-fill-pointer-p array) + (fill-pointer array))))) + (loop for i below (array-total-size array) + do (setf (row-major-aref new-array i) + (row-major-aref array i))) + new-array)) + +(deftype signed-array-length () + "A (possibly negated) array length." + '#.(let ((limit (1- array-dimension-limit))) + `(integer ,(- limit) ,limit))) + diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/bit.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/bit.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,522 @@ +;;; std/bit.lisp --- Bit manipulation + +;;; Commentary: + +;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html + +;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html + +;;; Code: +(in-package :std/bit) + +;;; Types +;; Bytes aren't necessarily 8 bits wide in Lisp. OCTET is always 8 +;; bits. +(deftype octet () '(unsigned-byte 8)) +(deftype octet-vector (&optional length) + `(simple-array octet (,length))) + +;;; Bits +(defun make-bits (length &rest args) + (apply #'make-array length (nconc (list :element-type 'bit) args))) + +;; https://graphics.stanford.edu/~seander/bithacks.html +;; http://www.azillionmonkeys.com/qed/asmexample.html +(defun haipart (n count) + (declare (fixnum n count)) + (let ((x (abs n))) + (if (minusp count) + (ldb (byte (- count) 0) x) + (ldb (byte count (max 0 (- (integer-length x) count))) + x)))) + +;; minusp = 38 bytes + +;; 29 bytes +(defun sign-bit (n) + "compute the sign bit of a fixnum. If N < 0 return -1 else return 0." + (declare (fixnum n)) + (ash n (- 0 (integer-length n)))) + +;; 51 bytes (speed 3) +;; 67 bytes (speed 1) +(defun different-signs-p (x y) + "Return non-nil iff x and y have opposite signs." + (declare (fixnum x y) (optimize (speed 1))) + (< (expt x y) 0)) + +;; TODO 2024-02-23: +(defun mortify-bits (x y) + "Interleave the bits of two numbers (Mortan numbers)." + (declare (fixnum x y) + (ignore x y)) + ;; (loop for i across (integer-length) + ;; with z = 0 + ;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1); + ;; do () + ;; return z) + ) + +(defun int-list-bits (n) + (declare (fixnum n)) + (let ((bits '())) + (dotimes (position (integer-length n) bits) + (push (ldb (byte 1 position) n) bits)))) + +(defun int-bit-vector (n) + (declare (fixnum n)) + (let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) + (dotimes (position (integer-length n) bits) + (vector-push-extend (ldb (byte 1 position) n) bits)))) + +(defun aref-bit (octets idx) + (declare (octet-vector octets) (fixnum idx)) + (multiple-value-bind (octet-idx bit-idx) + (truncate idx 8) + (ldb (byte 1 bit-idx) + (aref octets octet-idx)))) + +(defun make-bit-vector (size &optional (fill 0)) + "Make a BIT-VECTOR with SIZE and initial-element FILL which must be a +BIT 0|1. Note that this representation is not as useful as you might +think - bit-vectors don't have a direct mapping to integers/fixnums -- +they are vectors (AKA arrays) first, and bits second. Attempting to +perform bitwise-ops ends up being very inefficient so whenever +possible, stick with fixnums and use LOG* functions." + (declare (bit fill)) + (make-array size :initial-element fill :adjustable nil :element-type 'bit)) + +;; simple setter/getter for integer bits +(define-setf-expander logbit (index place &environment env) + (multiple-value-bind (temps vals stores store-form access-form) + (get-setf-expansion place env) + (let ((i (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,i ,@temps) + `(,index ,@vals) + `(,store) + `(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form)) + ,@(cdr stores)) + ,store-form + ,store) + `(logbit ,i ,access-form))))) + +(defun logbit (idx n) + (declare (fixnum idx n)) + (ldb (byte 1 idx) n)) + +;;; Bitfields + +;; see https://github.com/marcoheisig/bitfield + +;; A bitfield is a simple, efficient mechanism for storing multiple +;; discrete states into a single non-negative integer. + +(deftype bitfield () + "A bitfield is a non-negative integer that efficiently encodes +information about some booleans, enumerations, or small integers." + 'unsigned-byte) + +;;; Bitfield Slots +(defgeneric bitfield-slot-name (bitfield-slot) + (:documentation + "Returns a symbol that is the name of the bitfield slot.")) + +(defgeneric bitfield-slot-start (bitfield-slot) + (:documentation + "Returns the position of the first bit of this slot in the bitfield.")) + +(defgeneric bitfield-slot-end (bitfield-slot) + (:documentation + "Returns the position right after the last bit of this slot in the bitfield.")) + +(defgeneric bitfield-slot-size (bitfield-slot) + (:documentation + "Returns an unsigned byte that is the number of distinct states of the slot.")) + +(defgeneric bitfield-slot-initform (bitfield-slot) + (:documentation + "Returns a form that produces the initial value for that slot.")) + +(defgeneric bitfield-slot-pack (bitfield-slot value-form) + (:documentation + "Takes a form that produces a value and turns it into a form that produces +a non-negative integer representing that value.")) + +(defgeneric bitfield-slot-unpack (bitfield-slot value-form) + (:documentation + "Take a form that produces a value that is encoded as a non-negative +integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that +produces the decoded value.")) + +(defgeneric parse-atomic-bitfield-slot-specifier + (specifier &key initform) + (:documentation + "Parses an atomic bitfield slot specifier, i.e., a bitfield slot +specifier that is not a list. Returns three values: + +1. A designator for a bitfield slot class. + +2. The size of the bitfield slot. + +3. A list of additional arguments that will be supplied to MAKE-INSTANCE +when creating the bitfield slot instance.")) + +(defgeneric parse-compound-bitfield-slot-specifier + (specifier arguments &key initform) + (:documentation + "Parses a compount bitfield slot specifier, i.e., a bitfield slot +specifier that is a list. The SPECIFIER is the CAR of that list and the +ARGUMENTS are the CDR of that list. Returns three values: + +1. A designator for a bitfield slot class. + +2. The size of the bitfield slot. + +3. A list of additional arguments that will be supplied to MAKE-INSTANCE +when creating the bitfield slot instance.")) + +(defclass bitfield-slot () + ((%name :initarg :name :reader bitfield-slot-name) + (%initform :initarg :initform :reader bitfield-slot-initform) + (%start :initarg :start :reader bitfield-slot-start) + (%end :initarg :end :reader bitfield-slot-end) + (%size :initarg :size :reader bitfield-slot-size))) + +;;; Boolean Slots +(defclass bitfield-boolean-slot (bitfield-slot) + ()) + +(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form) + `(if ,value-form 1 0)) + +(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form) + `(ecase ,value-form (0 nil) (1 t))) + +(defmethod parse-atomic-bitfield-slot-specifier + ((specifier (eql 'boolean)) &key (initform 'nil)) + (values 'bitfield-boolean-slot + 2 + `(:initform ,initform))) + +;;; Integer Slots +(defclass bitfield-integer-slot (bitfield-slot) + ((%offset + :type integer + :initarg :offset + :reader bitfield-integer-slot-offset))) + +(defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form) + (let ((offset (bitfield-integer-slot-offset slot)) + (size (bitfield-slot-size slot))) + `(the (integer 0 (,size)) + (- (the (integer ,offset (,(+ offset size))) ,value-form) + ,offset)))) + +(defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form) + (let ((offset (bitfield-integer-slot-offset slot)) + (size (bitfield-slot-size slot))) + `(the (integer ,offset (,(+ offset size))) + (+ ,value-form ,offset)))) + +(defmethod parse-atomic-bitfield-slot-specifier + ((specifier (eql 'bit)) &key (initform '0)) + (values 'bitfield-unsigned-byte-slot + 2 + `(:offset 0 :initform ,initform))) + +(defmethod parse-compound-bitfield-slot-specifier + ((specifier (eql 'unsigned-byte)) arguments &key (initform '0)) + (destructuring-bind (bits) arguments + (check-type bits unsigned-byte) + (values 'bitfield-integer-slot + (expt 2 bits) + `(:offset 0 :initform ,initform)))) + +(defmethod parse-compound-bitfield-slot-specifier + ((specifier (eql 'signed-byte)) arguments &key (initform '0)) + (destructuring-bind (bits) arguments + (check-type bits unsigned-byte) + (values 'bitfield-integer-slot + (expt 2 bits) + `(:offset ,(- (expt 2 (1- bits))) :initform ,initform)))) + +(defmethod parse-compound-bitfield-slot-specifier + ((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p)) + (flet ((fail () + (error "Invalid integer bitfield slot specifier: ~S" + `(integer ,@bounds)))) + (unless (typep bounds '(cons t (cons t null))) + (fail)) + (destructuring-bind (lo hi) bounds + (let* ((start (typecase lo + (integer lo) + ((cons integer null) + (1+ (first lo))) + (otherwise (fail)))) + (end (typecase hi + (integer (1+ hi)) + ((cons integer null) + (first hi)) + (otherwise (fail)))) + (size (- end start))) + (unless (plusp size) + (fail)) + (values 'bitfield-integer-slot + size + `(:offset ,start :initform ,(if initform-supplied-p initform start))))))) + +;;; Member Slots +(defclass bitfield-member-slot (bitfield-slot) + ((%objects + :type list + :initarg :objects + :reader bitfield-member-slot-objects))) + +(defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form) + `(ecase ,value-form + ,@(loop for key in (bitfield-member-slot-objects slot) + for value from 0 + collect `((,key) ,value)))) + +(defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form) + `(ecase ,value-form + ,@(loop for key from 0 + for value in (bitfield-member-slot-objects slot) + collect `((,key) ',value)))) + +(defmethod parse-compound-bitfield-slot-specifier + ((specifier (eql 'member)) objects &key (initform `',(first objects))) + (values 'bitfield-member-slot + (length objects) + `(:initform ,initform :objects ,objects))) + +;;; Parsing +;; The position right after the last slot that has been parsed so far. +(defvar *bitfield-position*) + +(defun parse-bitfield-slot (slot) + (destructuring-bind (slot-name slot-specifier &rest rest) slot + (check-type slot-name symbol) + (multiple-value-bind (slot-class size args) + (if (consp slot-specifier) + (apply #'parse-compound-bitfield-slot-specifier + (car slot-specifier) + (cdr slot-specifier) + rest) + (apply #'parse-atomic-bitfield-slot-specifier + slot-specifier + rest)) + (apply #'make-instance slot-class + :name slot-name + :size size + :start *bitfield-position* + :end (incf *bitfield-position* (integer-length (1- size))) + args)))) + +(defmacro define-bitfield (name &body slots) + "Defines an encoding of enumerable properties like booleans, +integers or finite sets as a single non-negative integer. + +For a supplied bitfield name NAME, and for some slot definitions of the +form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines +the following functions: + +1. A constructor named MAKE-{NAME}, that takes one keyword argument per + SLOT-NAME, similar to the default constructor generated by DEFSTRUCT. + It returns a bitfield whose entries have the values indicated by the + keyword arguments, or the supplied initform. + +2. A clone operation named CLONE-{NAME}, that takes an existing bitfield + and one keyword argument per SLOT-NAME. It returns a copy of the + existing bitfield, but where each supplied keyword argument supersedes + the value of the corresponding slot. + +3. A reader function named {NAME}-{SLOT-NAME} for each slot. + +In addition to these functions, NAME is defined as a suitable subtype of +UNSIGNED-BYTE. + +This macro supports boolean, integer, and member slots. It is also +possible to add new kinds of slots by defining new subclasses of +BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK, +BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or +PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER. + + Example: + + (define-bitfield examplebits + (a boolean) + (b (signed-byte 2)) + (c (unsigned-byte 3) :initform 1) + (d (integer -100 100)) + (e (member foo bar baz))) + + (defun examplebits-values (examplebits) + (list + (examplebits-a examplebits) + (examplebits-b examplebits) + (examplebits-c examplebits) + (examplebits-d examplebits) + (examplebits-e examplebits))) + + (defparameter *default* (make-examplebits)) + + (examplebits-values *default*) + ;; => (nil 0 1 -100 foo) + + (defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz)) + + (examplebits-values *explicit*) + ;; => (t -1 7 42 baz) + + (defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar)) + + (examplebits-values *clone*) + ;; => (nil -1 2 -12 bar) +" + (let* ((*bitfield-position* 0) + (package (symbol-package name)) + (constructor + (intern (concatenate 'string "MAKE-" (symbol-name name)) package)) + (cloner + (intern (concatenate 'string "CLONE-" (symbol-name name)) package)) + (reader-prefix + (concatenate 'string )) + (slots + (mapcar #'parse-bitfield-slot slots)) + (reader-names + (loop for slot in slots + collect + (intern (concatenate 'string (symbol-name name) "-" reader-prefix + (symbol-name (bitfield-slot-name slot))) + package)))) + `(progn + (deftype ,name () '(unsigned-byte ,*bitfield-position*)) + ;; Define all slot readers. + ,@(loop for slot in slots + for reader-name in reader-names + for start = (bitfield-slot-start slot) + for end = (bitfield-slot-end slot) + collect + `(declaim (inline ,reader-name)) + collect + `(defun ,reader-name (,name) + (declare (,name ,name)) + ,(bitfield-slot-unpack + slot + `(ldb (byte ,(- end start) ,start) ,name)))) + ;; Define the cloner. + (declaim (inline ,cloner)) + (defun ,cloner + (,name &key ,@(loop for slot in slots + for reader-name in reader-names + collect + `(,(bitfield-slot-name slot) + (,reader-name ,name)))) + (declare (,name ,name)) + (logior + ,@(loop for slot in slots + collect + `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) + ,(bitfield-slot-start slot))))) + ;; Define the constructor. + (declaim (inline ,constructor)) + (defun ,constructor + (&key ,@(loop for slot in slots + collect + `(,(bitfield-slot-name slot) + ,(bitfield-slot-initform slot)))) + (logior + ,@(loop for slot in slots + collect + `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) + ,(bitfield-slot-start slot))))) + ',name))) + +;;; From bit-smasher +(declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*)) +(defvar *bit-map* #(#*0000 + #*0001 + #*0010 + #*0011 + #*0100 + #*0101 + #*0110 + #*0111 + #*1000 + #*1001 + #*1010 + #*1011 + #*1100 + #*1101 + #*1110 + #*1111)) + +(deftype hex-char () + `(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\a #\b #\c #\d #\e #\f + #\A #\B #\C #\D #\E #\F)) + +(declaim (ftype (function (hex-char) (integer 0 16)) hexchar->int) + (inline hexchar->int)) +(defun hexchar-to-int (char) + "Return the bit vector associated with a hex-value character CHAR from *bit-map*." + (declare (optimize (speed 2) (safety 0))) + (cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0))) + ((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10))) + (t (- (char-code char) #.(- (char-code #\A) 10)) + ;; always return these results + #+nil (char<= #\A char #\F)))) + +;;; From Ironclad +(defun hex-string-to-octet-vector (string &aux (start 0) (end (length string))) + "Parses a substring of STRING delimited by START and END of +hexadecimal digits into a byte array." + (declare (type string string)) + (let* ((length + (ash (- end start) -1) + #+nil (/ (- end start) 2)) + (key (make-array length :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8)) key)) + (loop for i from 0 + for j from start below end by 2 + do (setf (aref key i) + (+ (* (hexchar-to-int (char string j)) 16) + (hexchar-to-int (char string (1+ j))))) + finally (return key)))) + +(defun octet-vector-to-hex-string (vector) + "Return a string containing the hexadecimal representation of the +subsequence of VECTOR between START and END. ELEMENT-TYPE controls +the element-type of the returned string." + (declare (type (vector (unsigned-byte 8)) vector)) + (let* ((length (length vector)) + (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string))) + (loop with string = (make-string (* length 2) :element-type 'base-char) + for i from 0 below length + for j from 0 by 2 + do (let ((byte (aref vector i))) + (declare (optimize (safety 0))) + (setf (aref string j) + (aref hexdigits (ldb (byte 4 4) byte)) + (aref string (1+ j)) + (aref hexdigits (ldb (byte 4 0) byte)))) + finally (return string)))) + +(defun octets-to-integer (octet-vec &optional (end (length octet-vec))) + (declare (type (simple-array (unsigned-byte 8)) octet-vec)) + (do ((j 0 (1+ j)) + (sum 0)) + ((>= j end) sum) + (setf sum (+ (aref octet-vec j) (ash sum 8))))) + +(defun integer-to-octets (bignum &optional (n-bits (integer-length bignum))) + (let* ((n-bytes (ceiling n-bits 8)) + (octet-vec (make-array n-bytes :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8)) octet-vec)) + (loop for i from (1- n-bytes) downto 0 + for index from 0 + do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum)) + finally (return octet-vec)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/bits.lisp --- a/lisp/std/bits.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,522 +0,0 @@ -;;; bits.lisp --- Bit manipulation - -;;; Commentary: - -;; CMUCL doc: https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node132.html - -;; quick primer: https://cp-algorithms.com/algebra/bit-manipulation.html - -;;; Code: -(in-package :std) - -;;; Types -;; Bytes aren't necessarily 8 bits wide in Lisp. OCTET is always 8 -;; bits. -(deftype octet () '(unsigned-byte 8)) -(deftype octet-vector (&optional length) - `(simple-array octet (,length))) - -;;; Bits -(defun make-bits (length &rest args) - (apply #'make-array length (nconc (list :element-type 'bit) args))) - -;; https://graphics.stanford.edu/~seander/bithacks.html -;; http://www.azillionmonkeys.com/qed/asmexample.html -(defun haipart (n count) - (declare (fixnum n count)) - (let ((x (abs n))) - (if (minusp count) - (ldb (byte (- count) 0) x) - (ldb (byte count (max 0 (- (integer-length x) count))) - x)))) - -;; minusp = 38 bytes - -;; 29 bytes -(defun sign-bit (n) - "compute the sign bit of a fixnum. If N < 0 return -1 else return 0." - (declare (fixnum n)) - (ash n (- 0 (integer-length n)))) - -;; 51 bytes (speed 3) -;; 67 bytes (speed 1) -(defun different-signs-p (x y) - "Return non-nil iff x and y have opposite signs." - (declare (fixnum x y) (optimize (speed 1))) - (< (expt x y) 0)) - -;; TODO 2024-02-23: -(defun mortify-bits (x y) - "Interleave the bits of two numbers (Mortan numbers)." - (declare (fixnum x y) - (ignore x y)) - ;; (loop for i across (integer-length) - ;; with z = 0 - ;; ;; z |= (x & 1U << i) << i | (y & 1U << i) << (i + 1); - ;; do () - ;; return z) - ) - -(defun int-list-bits (n) - (declare (fixnum n)) - (let ((bits '())) - (dotimes (position (integer-length n) bits) - (push (ldb (byte 1 position) n) bits)))) - -(defun int-bit-vector (n) - (declare (fixnum n)) - (let ((bits (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) - (dotimes (position (integer-length n) bits) - (vector-push-extend (ldb (byte 1 position) n) bits)))) - -(defun aref-bit (octets idx) - (declare (octet-vector octets) (fixnum idx)) - (multiple-value-bind (octet-idx bit-idx) - (truncate idx 8) - (ldb (byte 1 bit-idx) - (aref octets octet-idx)))) - -(defun make-bit-vector (size &optional (fill 0)) - "Make a BIT-VECTOR with SIZE and initial-element FILL which must be a -BIT 0|1. Note that this representation is not as useful as you might -think - bit-vectors don't have a direct mapping to integers/fixnums -- -they are vectors (AKA arrays) first, and bits second. Attempting to -perform bitwise-ops ends up being very inefficient so whenever -possible, stick with fixnums and use LOG* functions." - (declare (bit fill)) - (make-array size :initial-element fill :adjustable nil :element-type 'bit)) - -;; simple setter/getter for integer bits -(define-setf-expander logbit (index place &environment env) - (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion place env) - (let ((i (gensym)) - (store (gensym)) - (stemp (first stores))) - (values `(,i ,@temps) - `(,index ,@vals) - `(,store) - `(let ((,stemp (dpb ,store (byte 1 ,i) ,access-form)) - ,@(cdr stores)) - ,store-form - ,store) - `(logbit ,i ,access-form))))) - -(defun logbit (idx n) - (declare (fixnum idx n)) - (ldb (byte 1 idx) n)) - -;;; Bitfields - -;; see https://github.com/marcoheisig/bitfield - -;; A bitfield is a simple, efficient mechanism for storing multiple -;; discrete states into a single non-negative integer. - -(deftype bitfield () - "A bitfield is a non-negative integer that efficiently encodes -information about some booleans, enumerations, or small integers." - 'unsigned-byte) - -;;; Bitfield Slots -(defgeneric bitfield-slot-name (bitfield-slot) - (:documentation - "Returns a symbol that is the name of the bitfield slot.")) - -(defgeneric bitfield-slot-start (bitfield-slot) - (:documentation - "Returns the position of the first bit of this slot in the bitfield.")) - -(defgeneric bitfield-slot-end (bitfield-slot) - (:documentation - "Returns the position right after the last bit of this slot in the bitfield.")) - -(defgeneric bitfield-slot-size (bitfield-slot) - (:documentation - "Returns an unsigned byte that is the number of distinct states of the slot.")) - -(defgeneric bitfield-slot-initform (bitfield-slot) - (:documentation - "Returns a form that produces the initial value for that slot.")) - -(defgeneric bitfield-slot-pack (bitfield-slot value-form) - (:documentation - "Takes a form that produces a value and turns it into a form that produces -a non-negative integer representing that value.")) - -(defgeneric bitfield-slot-unpack (bitfield-slot value-form) - (:documentation - "Take a form that produces a value that is encoded as a non-negative -integer (as produced by BITFIELD-SLOT-PACK), and turn it into a form that -produces the decoded value.")) - -(defgeneric parse-atomic-bitfield-slot-specifier - (specifier &key initform) - (:documentation - "Parses an atomic bitfield slot specifier, i.e., a bitfield slot -specifier that is not a list. Returns three values: - -1. A designator for a bitfield slot class. - -2. The size of the bitfield slot. - -3. A list of additional arguments that will be supplied to MAKE-INSTANCE -when creating the bitfield slot instance.")) - -(defgeneric parse-compound-bitfield-slot-specifier - (specifier arguments &key initform) - (:documentation - "Parses a compount bitfield slot specifier, i.e., a bitfield slot -specifier that is a list. The SPECIFIER is the CAR of that list and the -ARGUMENTS are the CDR of that list. Returns three values: - -1. A designator for a bitfield slot class. - -2. The size of the bitfield slot. - -3. A list of additional arguments that will be supplied to MAKE-INSTANCE -when creating the bitfield slot instance.")) - -(defclass bitfield-slot () - ((%name :initarg :name :reader bitfield-slot-name) - (%initform :initarg :initform :reader bitfield-slot-initform) - (%start :initarg :start :reader bitfield-slot-start) - (%end :initarg :end :reader bitfield-slot-end) - (%size :initarg :size :reader bitfield-slot-size))) - -;;; Boolean Slots -(defclass bitfield-boolean-slot (bitfield-slot) - ()) - -(defmethod bitfield-slot-pack ((slot bitfield-boolean-slot) value-form) - `(if ,value-form 1 0)) - -(defmethod bitfield-slot-unpack ((slot bitfield-boolean-slot) value-form) - `(ecase ,value-form (0 nil) (1 t))) - -(defmethod parse-atomic-bitfield-slot-specifier - ((specifier (eql 'boolean)) &key (initform 'nil)) - (values 'bitfield-boolean-slot - 2 - `(:initform ,initform))) - -;;; Integer Slots -(defclass bitfield-integer-slot (bitfield-slot) - ((%offset - :type integer - :initarg :offset - :reader bitfield-integer-slot-offset))) - -(defmethod bitfield-slot-pack ((slot bitfield-integer-slot) value-form) - (let ((offset (bitfield-integer-slot-offset slot)) - (size (bitfield-slot-size slot))) - `(the (integer 0 (,size)) - (- (the (integer ,offset (,(+ offset size))) ,value-form) - ,offset)))) - -(defmethod bitfield-slot-unpack ((slot bitfield-integer-slot) value-form) - (let ((offset (bitfield-integer-slot-offset slot)) - (size (bitfield-slot-size slot))) - `(the (integer ,offset (,(+ offset size))) - (+ ,value-form ,offset)))) - -(defmethod parse-atomic-bitfield-slot-specifier - ((specifier (eql 'bit)) &key (initform '0)) - (values 'bitfield-unsigned-byte-slot - 2 - `(:offset 0 :initform ,initform))) - -(defmethod parse-compound-bitfield-slot-specifier - ((specifier (eql 'unsigned-byte)) arguments &key (initform '0)) - (destructuring-bind (bits) arguments - (check-type bits unsigned-byte) - (values 'bitfield-integer-slot - (expt 2 bits) - `(:offset 0 :initform ,initform)))) - -(defmethod parse-compound-bitfield-slot-specifier - ((specifier (eql 'signed-byte)) arguments &key (initform '0)) - (destructuring-bind (bits) arguments - (check-type bits unsigned-byte) - (values 'bitfield-integer-slot - (expt 2 bits) - `(:offset ,(- (expt 2 (1- bits))) :initform ,initform)))) - -(defmethod parse-compound-bitfield-slot-specifier - ((specifier (eql 'integer)) bounds &key (initform nil initform-supplied-p)) - (flet ((fail () - (error "Invalid integer bitfield slot specifier: ~S" - `(integer ,@bounds)))) - (unless (typep bounds '(cons t (cons t null))) - (fail)) - (destructuring-bind (lo hi) bounds - (let* ((start (typecase lo - (integer lo) - ((cons integer null) - (1+ (first lo))) - (otherwise (fail)))) - (end (typecase hi - (integer (1+ hi)) - ((cons integer null) - (first hi)) - (otherwise (fail)))) - (size (- end start))) - (unless (plusp size) - (fail)) - (values 'bitfield-integer-slot - size - `(:offset ,start :initform ,(if initform-supplied-p initform start))))))) - -;;; Member Slots -(defclass bitfield-member-slot (bitfield-slot) - ((%objects - :type list - :initarg :objects - :reader bitfield-member-slot-objects))) - -(defmethod bitfield-slot-pack ((slot bitfield-member-slot) value-form) - `(ecase ,value-form - ,@(loop for key in (bitfield-member-slot-objects slot) - for value from 0 - collect `((,key) ,value)))) - -(defmethod bitfield-slot-unpack ((slot bitfield-member-slot) value-form) - `(ecase ,value-form - ,@(loop for key from 0 - for value in (bitfield-member-slot-objects slot) - collect `((,key) ',value)))) - -(defmethod parse-compound-bitfield-slot-specifier - ((specifier (eql 'member)) objects &key (initform `',(first objects))) - (values 'bitfield-member-slot - (length objects) - `(:initform ,initform :objects ,objects))) - -;;; Parsing -;; The position right after the last slot that has been parsed so far. -(defvar *bitfield-position*) - -(defun parse-bitfield-slot (slot) - (destructuring-bind (slot-name slot-specifier &rest rest) slot - (check-type slot-name symbol) - (multiple-value-bind (slot-class size args) - (if (consp slot-specifier) - (apply #'parse-compound-bitfield-slot-specifier - (car slot-specifier) - (cdr slot-specifier) - rest) - (apply #'parse-atomic-bitfield-slot-specifier - slot-specifier - rest)) - (apply #'make-instance slot-class - :name slot-name - :size size - :start *bitfield-position* - :end (incf *bitfield-position* (integer-length (1- size))) - args)))) - -(defmacro define-bitfield (name &body slots) - "Defines an encoding of enumerable properties like booleans, -integers or finite sets as a single non-negative integer. - -For a supplied bitfield name NAME, and for some slot definitions of the -form (SLOT-NAME TYPE &KEY INITFORM &ALLOW-OTHER-KEYS), this macro defines -the following functions: - -1. A constructor named MAKE-{NAME}, that takes one keyword argument per - SLOT-NAME, similar to the default constructor generated by DEFSTRUCT. - It returns a bitfield whose entries have the values indicated by the - keyword arguments, or the supplied initform. - -2. A clone operation named CLONE-{NAME}, that takes an existing bitfield - and one keyword argument per SLOT-NAME. It returns a copy of the - existing bitfield, but where each supplied keyword argument supersedes - the value of the corresponding slot. - -3. A reader function named {NAME}-{SLOT-NAME} for each slot. - -In addition to these functions, NAME is defined as a suitable subtype of -UNSIGNED-BYTE. - -This macro supports boolean, integer, and member slots. It is also -possible to add new kinds of slots by defining new subclasses of -BITFIELD-SLOT and the corresponding methods on BITFIELD-SLOT-PACK, -BITFIELD-SLOT-UNPACK and PARSE-ATOMIC-BITFIELD-SLOT-SPECIFIER or -PARSE-COMPOUND-BITFIELD-SLOT-SPECIFIER. - - Example: - - (define-bitfield examplebits - (a boolean) - (b (signed-byte 2)) - (c (unsigned-byte 3) :initform 1) - (d (integer -100 100)) - (e (member foo bar baz))) - - (defun examplebits-values (examplebits) - (list - (examplebits-a examplebits) - (examplebits-b examplebits) - (examplebits-c examplebits) - (examplebits-d examplebits) - (examplebits-e examplebits))) - - (defparameter *default* (make-examplebits)) - - (examplebits-values *default*) - ;; => (nil 0 1 -100 foo) - - (defparameter *explicit* (make-examplebits :a t :b -1 :c 7 :d 42 :e 'baz)) - - (examplebits-values *explicit*) - ;; => (t -1 7 42 baz) - - (defparameter *clone* (clone-examplebits *explicit* :a nil :b -1 :c 2 :d -12 :e 'bar)) - - (examplebits-values *clone*) - ;; => (nil -1 2 -12 bar) -" - (let* ((*bitfield-position* 0) - (package (symbol-package name)) - (constructor - (intern (concatenate 'string "MAKE-" (symbol-name name)) package)) - (cloner - (intern (concatenate 'string "CLONE-" (symbol-name name)) package)) - (reader-prefix - (concatenate 'string )) - (slots - (mapcar #'parse-bitfield-slot slots)) - (reader-names - (loop for slot in slots - collect - (intern (concatenate 'string (symbol-name name) "-" reader-prefix - (symbol-name (bitfield-slot-name slot))) - package)))) - `(progn - (deftype ,name () '(unsigned-byte ,*bitfield-position*)) - ;; Define all slot readers. - ,@(loop for slot in slots - for reader-name in reader-names - for start = (bitfield-slot-start slot) - for end = (bitfield-slot-end slot) - collect - `(declaim (inline ,reader-name)) - collect - `(defun ,reader-name (,name) - (declare (,name ,name)) - ,(bitfield-slot-unpack - slot - `(ldb (byte ,(- end start) ,start) ,name)))) - ;; Define the cloner. - (declaim (inline ,cloner)) - (defun ,cloner - (,name &key ,@(loop for slot in slots - for reader-name in reader-names - collect - `(,(bitfield-slot-name slot) - (,reader-name ,name)))) - (declare (,name ,name)) - (logior - ,@(loop for slot in slots - collect - `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) - ,(bitfield-slot-start slot))))) - ;; Define the constructor. - (declaim (inline ,constructor)) - (defun ,constructor - (&key ,@(loop for slot in slots - collect - `(,(bitfield-slot-name slot) - ,(bitfield-slot-initform slot)))) - (logior - ,@(loop for slot in slots - collect - `(ash ,(bitfield-slot-pack slot (bitfield-slot-name slot)) - ,(bitfield-slot-start slot))))) - ',name))) - -;;; From bit-smasher -(declaim (type (simple-array (simple-bit-vector 4) (16)) *bit-map*)) -(defvar *bit-map* #(#*0000 - #*0001 - #*0010 - #*0011 - #*0100 - #*0101 - #*0110 - #*0111 - #*1000 - #*1001 - #*1010 - #*1011 - #*1100 - #*1101 - #*1110 - #*1111)) - -(deftype hex-char () - `(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 - #\a #\b #\c #\d #\e #\f - #\A #\B #\C #\D #\E #\F)) - -(declaim (ftype (function (hex-char) (integer 0 16)) hexchar->int) - (inline hexchar->int)) -(defun hexchar-to-int (char) - "Return the bit vector associated with a hex-value character CHAR from *bit-map*." - (declare (optimize (speed 2) (safety 0))) - (cond ((char<= #\0 char #\9) (- (char-code char) #.(char-code #\0))) - ((char<= #\a char #\f) (- (char-code char) #.(- (char-code #\a) 10))) - (t (- (char-code char) #.(- (char-code #\A) 10)) - ;; always return these results - #+nil (char<= #\A char #\F)))) - -;;; From Ironclad -(defun hex-string-to-octet-vector (string &aux (start 0) (end (length string))) - "Parses a substring of STRING delimited by START and END of -hexadecimal digits into a byte array." - (declare (type string string)) - (let* ((length - (ash (- end start) -1) - #+nil (/ (- end start) 2)) - (key (make-array length :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8)) key)) - (loop for i from 0 - for j from start below end by 2 - do (setf (aref key i) - (+ (* (hexchar-to-int (char string j)) 16) - (hexchar-to-int (char string (1+ j))))) - finally (return key)))) - -(defun octet-vector-to-hex-string (vector) - "Return a string containing the hexadecimal representation of the -subsequence of VECTOR between START and END. ELEMENT-TYPE controls -the element-type of the returned string." - (declare (type (vector (unsigned-byte 8)) vector)) - (let* ((length (length vector)) - (hexdigits #.(coerce "0123456789abcdef" 'simple-base-string))) - (loop with string = (make-string (* length 2) :element-type 'base-char) - for i from 0 below length - for j from 0 by 2 - do (let ((byte (aref vector i))) - (declare (optimize (safety 0))) - (setf (aref string j) - (aref hexdigits (ldb (byte 4 4) byte)) - (aref string (1+ j)) - (aref hexdigits (ldb (byte 4 0) byte)))) - finally (return string)))) - -(defun octets-to-integer (octet-vec &optional (end (length octet-vec))) - (declare (type (simple-array (unsigned-byte 8)) octet-vec)) - (do ((j 0 (1+ j)) - (sum 0)) - ((>= j end) sum) - (setf sum (+ (aref octet-vec j) (ash sum 8))))) - -(defun integer-to-octets (bignum &optional (n-bits (integer-length bignum))) - (let* ((n-bytes (ceiling n-bits 8)) - (octet-vec (make-array n-bytes :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8)) octet-vec)) - (loop for i from (1- n-bytes) downto 0 - for index from 0 - do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum)) - finally (return octet-vec)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/defpkg.lisp --- a/lisp/std/defpkg.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/defpkg.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -5,7 +5,7 @@ ;; ;;; Code: -(in-package :std) +(in-package :std/defpkg) (eval-when (:load-toplevel :compile-toplevel :execute) (defun find-package* (package-designator &optional (error t)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/err.lisp --- a/lisp/std/err.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/err.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -1,7 +1,7 @@ ;;; err.lisp --- Conditions and other exception handlers ;;; Code: -(in-package :std) +(in-package :std/err) (defvar *std-error-message* "An error occured") diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/file.lisp --- a/lisp/std/file.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/file.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,22 @@ ;; ;;; Code: -(in-package :std) +(in-package :std/file) + +;;; Sexp utils +;; (reexport-from :uiop :include '(read-file-form read-file-forms slurp-stream-forms)) + +(defun tmpfile (size) + "Create an anonymous temporary file of the given size. Returns a file descriptor." + (let (done fd pathname) + (unwind-protect + (progn + (setf (values fd pathname) (sb-posix:mkstemp "/dev/shm/tmp.XXXXXXXX")) + (sb-posix:unlink pathname) + (sb-posix:ftruncate fd size) + (setf done t)) + (when (and fd (not done)) (sb-posix:close fd))) + fd)) (declaim (inline octet-vector=/unsafe)) (defun octet-vector=/unsafe (v1 v2 start1 end1 start2 end2) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/fmt.lisp --- a/lisp/std/fmt.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/fmt.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -1,7 +1,7 @@ ;;; std/fmt.lisp --- printer and format utils ;;; Code: -(in-package :std) +(in-package :std/fmt) (defun iprintln (x &optional (n 2) stream) (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/fu.lisp --- a/lisp/std/fu.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,872 +0,0 @@ -;;; fu.lisp --- Function utilities - -;; - -;;; Code: -(in-package :std) - -(in-readtable :std) - -(defmacro! sortf (comparator &rest places) - (if places - `(tagbody - ,@(mapcar - #`(let ((,g!a #1=,(nth (car a1) places)) - (,g!b #2=,(nth (cadr a1) places))) - (if (,comparator ,g!b ,g!a) - (setf #1# ,g!b - #2# ,g!a))) - (build-batcher-sn (length places)))))) - -#+cl-ppcre -(defun dollar-symbol-p (s) - (and (symbolp s) - (> (length (symbol-name s)) 1) - (string= (symbol-name s) - "$" - :start1 0 - :end1 1) - (ignore-errors (parse-integer (subseq (symbol-name s) 1))))) - - -#+cl-ppcre -(defmacro! if-match ((match-regex str) then &optional else) - (let* ((dollars (remove-duplicates - (remove-if-not #'dollar-symbol-p - (flatten then)))) - (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>)) - 0))) - `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str) - (declare (ignorable ,g!matches ,g!captures)) - (let ((,g!captures-len (length ,g!captures))) - (declare (ignorable ,g!captures-len)) - (symbol-macrolet ,(mapcar #`(,(symb "$" a1) - (if (< ,g!captures-len ,a1) - (error "Too few matchs: ~a unbound." ,(mkstr "$" a1)) - (aref ,g!captures ,(1- a1)))) - (loop for i from 1 to top collect i)) - (if ,g!matches - ,then - ,else)))))) - -#+cl-ppcre -(defmacro when-match ((match-regex str) &body forms) - `(if-match (,match-regex ,str) - (progn ,@forms))) - -(defmacro once-only (specs &body forms) - "Constructs code whose primary goal is to help automate the handling of -multiple evaluation within macros. Multiple evaluation is handled by introducing -intermediate variables, in order to reuse the result of an expression. - -The returned value is a list of the form - - (let (( ) - ... - ( )) - ) - -where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order -to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of -evaluating the implicit progn FORMS within a special context determined by -SPECS. RES should make use of (reference) the intermediate variables. - -Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM). -Bare symbols are equivalent to the pair (SYMBOL SYMBOL). - -Each pair (SYMBOL INITFORM) specifies a single intermediate variable: - -- INITFORM is an expression evaluated to produce EXPR-i - -- SYMBOL is the name of the variable that will be bound around FORMS to the - corresponding gensym GENSYM-i, in order for FORMS to generate RES that - references the intermediate variable - -The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of -all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. - -Example: - - The following expression - - (let ((x '(incf y))) - (once-only (x) - `(cons ,x ,x))) - - ;;; => - ;;; (let ((#1=#:X123 (incf y))) - ;;; (cons #1# #1#)) - - could be used within a macro to avoid multiple evaluation like so - - (defmacro cons1 (x) - (once-only (x) - `(cons ,x ,x))) - - (let ((y 0)) - (cons1 (incf y))) - - ;;; => (1 . 1) - -Example: - - The following expression demonstrates the usage of the INITFORM field - - (let ((expr '(incf y))) - (once-only ((var `(1+ ,expr))) - `(list ',expr ,var ,var))) - - ;;; => - ;;; (let ((#1=#:VAR123 (1+ (incf y)))) - ;;; (list '(incf y) #1# #1)) - - which could be used like so - - (defmacro print-succ-twice (expr) - (once-only ((var `(1+ ,expr))) - `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) - - (let ((y 10)) - (print-succ-twice (incf y))) - - ;;; >> - ;;; Expr: (INCF Y), Once: 12, Twice: 12" - (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) - (names-and-forms (mapcar (lambda (spec) - (etypecase spec - (list - (destructuring-bind (name form) spec - (cons name form))) - (symbol - (cons spec spec)))) - specs))) - ;; bind in user-macro - `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) - gensyms names-and-forms) - ;; bind in final expansion - `(let (,,@(mapcar (lambda (g n) - ``(,,g ,,(cdr n))) - gensyms names-and-forms)) - ;; bind in user-macro - ,(let ,(mapcar (lambda (n g) (list (car n) g)) - names-and-forms gensyms) - ,@forms))))) - -;;;; DESTRUCTURING-*CASE - -(defun expand-destructuring-case (key clauses case) - (once-only (key) - `(if (typep ,key 'cons) - (,case (car ,key) - ,@(mapcar (lambda (clause) - (destructuring-bind ((keys . lambda-list) &body body) clause - `(,keys - (destructuring-bind ,lambda-list (cdr ,key) - ,@body)))) - clauses)) - (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) - -(defmacro destructuring-case (keyform &body clauses) - "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. -KEYFORM must evaluate to a CONS. - -Clauses are of the form: - - ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) - -The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, -is selected, and FORMs are then executed with CDR of KEY is destructured and -bound by the DESTRUCTURING-LAMBDA-LIST. - -Example: - - (defun dcase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)) - ((t &rest rest) - (format nil \"unknown: ~S\" rest)))) - - (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" - (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (dcase (list :alt1 1)) ; => \"alt: 1\" - (dcase (list :alt2 2)) ; => \"alt: 2\" - (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" - - (defun decase (x) - (destructuring-case x - ((:foo a b) - (format nil \"foo: ~S, ~S\" a b)) - ((:bar &key a b) - (format nil \"bar: ~S, ~S\" a b)) - (((:alt1 :alt2) a) - (format nil \"alt: ~S\" a)))) - - (decase (list :foo 1 2)) ; => \"foo: 1, 2\" - (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" - (decase (list :alt1 1)) ; => \"alt: 1\" - (decase (list :alt2 2)) ; => \"alt: 2\" - (decase (list :quux 1 2 3)) ; =| error -" - (expand-destructuring-case keyform clauses 'case)) - -(defmacro destructuring-ccase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ccase)) - -(defmacro destructuring-ecase (keyform &body clauses) - (expand-destructuring-case keyform clauses 'ecase)) - -(dolist (name '(destructuring-ccase destructuring-ecase)) - (setf (documentation name 'function) (documentation 'destructuring-case 'function))) - -;;; *-let --- control-flow let-binding macros -;; based on https://stevelosh.com/blog/2018/07/fun-with-macros-if-let/ - -(defmacro when-let (bindings &body body) - "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`. - - This macro combines `when` and `let`. It takes a list of bindings and - binds them like `let` before executing `body`, but if any binding's value - evaluates to `nil` the process stops and `nil` is immediately returned. - - Examples: - - (when-let ((a (progn (print :a) 1)) - (b (progn (print :b) 2)) - (list a b)) - ; => - :A - :B - (1 2) - - (when-let ((a (progn (print :a) nil)) - (b (progn (print :b) 2))) - (list a b)) - ; => - :A - NIL - - " - (with-gensyms (block) - `(block ,block - (let ,(loop :for (symbol value) :in bindings - :collect `(,symbol (or ,value - (return-from ,block nil)))) - ,@body)))) - -(defmacro when-let* (bindings &body body) - "Bind `bindings` serially and execute `body`, short-circuiting on `nil`. - - This macro combines `when` and `let*`. It takes a list of bindings - and binds them like `let*` before executing `body`, but if any - binding's value evaluates to `nil` the process stops and `nil` is - immediately returned. - - Examples: - - (when-let* ((a (progn (print :a) 1)) - (b (progn (print :b) (1+ a))) - (list a b)) - ; => - :A - :B - (1 2) - - (when-let* ((a (progn (print :a) nil)) - (b (progn (print :b) (1+ a)))) - (list a b)) - ; => - :A - NIL - - " - (with-gensyms (block) - `(block ,block - (let* ,(loop :for (symbol value) :in bindings - :collect `(,symbol (or ,value - (return-from ,block nil)))) - ,@body)))) - -(defmacro if-let (bindings &body body) - "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise. - - `body` must be of the form `(...optional-declarations... then else)`. - - This macro combines `if` and `let`. It takes a list of bindings and - binds them like `let` before executing the `then` branch of `body`, but - if any binding's value evaluates to `nil` the process stops there and the - `else` branch is immediately executed (with no bindings in effect). - - If any `optional-declarations` are included they will only be in effect - for the `then` branch. - - Examples: - - (if-let ((a (progn (print :a) 1)) - (b (progn (print :b) 2))) - (list a b) - 'nope) - ; => - :A - :B - (1 2) - - (if-let ((a (progn (print :a) nil)) - (b (progn (print :b) 2))) - (list a b) - 'nope) - ; => - :A - NOPE - - " - (with-gensyms (outer inner) - (multiple-value-bind (body declarations) (parse-body body) - (destructuring-bind (then else) body - `(block ,outer - (block ,inner - (let ,(loop :for (symbol value) :in bindings - :collect `(,symbol (or ,value - (return-from ,inner nil)))) - ,@declarations - (return-from ,outer ,then))) - ,else))))) - -(defmacro if-let* (bindings then else) - "Bind `bindings` serially and execute `then` if all are true, or `else` otherwise. - - This macro combines `if` and `let*`. It takes a list of bindings and - binds them like `let*` before executing `then`, but if any binding's - value evaluates to `nil` the process stops and the `else` branch is - immediately executed (with no bindings in effect). - - Examples: - - (if-let* ((a (progn (print :a) 1)) - (b (progn (print :b) (1+ a))) - (list a b) - 'nope) - ; => - :A - :B - (1 2) - - (if-let* ((a (progn (print :a) nil)) - (b (progn (print :b) (1+ a)))) - (list a b) - 'nope) - ; => - :A - NOPE - - " - (with-gensyms (outer inner) - `(block ,outer - (block ,inner - (let* ,(loop :for (symbol value) :in bindings - :collect `(,symbol (or ,value - (return-from ,inner nil)))) - (return-from ,outer ,then))) - ,else))) - - -(defmacro def! (name &body body) - "`defun' without args." - `(defun ,name () ,@body)) - -(defmacro eval-always (&body body) - `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) - -;;; TODO 2023-09-04: Env - -;;; Introspection -;; (eval-always (require :sb-introspect)) - -;; (reexport-from :sb-introspect -;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit -;; :method-combination-lambda-list :deftype-lambda-list -;; :primitive-object-size :allocation-information -;; :function-type -;; :who-specializes-directly :who-specializes-generally -;; :find-function-callees :find-function-callers)) - -;; ;;; Compiler - -;; (reexport-from :sb-c -;; :include '(:define-source-transformation -;; :parse-eval-when-situations -;; :source-location)) -;;; Definitions -(defun %reevaluate-constant (name value test) - (if (not (boundp name)) - value - (let ((old (symbol-value name)) - (new value)) - (if (not (constantp name)) - (prog1 new - (cerror "Try to redefine the variable as a constant." - "~@<~S is an already bound non-constant variable ~ - whose value is ~S.~:@>" name old)) - (if (funcall test old new) - old - (restart-case - (error "~@<~S is an already defined constant whose value ~ - ~S is not equal to the provided initial value ~S ~ - under ~S.~:@>" name old new test) - (ignore () - :report "Retain the current value." - old) - (continue () - :report "Try to redefine the constant." - new))))))) - -(defmacro define-constant (name initial-value &key (test #'eql) documentation) - "Ensures that the global variable named by NAME is a constant with a value -that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a -/function designator/ that defaults to EQL. If DOCUMENTATION is given, it -becomes the documentation string of the constant. - -Signals an error if NAME is already a bound non-constant variable. - -Signals an error if NAME is already a constant variable whose value is not -equal under TEST to result of evaluating INITIAL-VALUE." - `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) - ,@(when documentation `(,documentation)))) - -;;; Named Lambdas -;; (reexport-from :sb-int :include '(:make-macro-lambda :parse-lambda-list)) - -;;; Sexp utils -;; (reexport-from :uiop :include '(read-file-form read-file-forms slurp-stream-forms)) - -;;; cl-bench utils -;; Destructive merge of two sorted lists. -;; From Hansen's MS thesis. -(defun merge! (a b predicate) - (labels ((merge-loop (r a b) - (cond ((funcall predicate (car b) (car a)) - (setf (cdr r) b) - (if (null (cdr b)) - (setf (cdr b) a) - (merge-loop b a (cdr b)))) - (t ; (car a) <= (car b) - (setf (cdr r) a) - (if (null (cdr a)) - (setf (cdr a) b) - (merge-loop a (cdr a) b)))))) - (cond ((null a) b) - ((null b) a) - ((funcall predicate (car b) (car a)) - (if (null (cdr b)) - (setf (cdr b) a) - (merge-loop b a (cdr b))) - b) - (t ; (car a) <= (car b) - (if (null (cdr a)) - (setf (cdr a) b) - (merge-loop a (cdr a) b)) - a)))) - -;; Stable sort procedure which copies the input list and then sorts -;; the new list imperatively. On the systems we have benchmarked, -;; this generic list sort has been at least as fast and usually much -;; faster than the library's sort routine. -;; Due to Richard O'Keefe; algorithm attributed to D.H.D. Warren. -(defun sort! (seq predicate) - (labels ((astep (n) - (cond ((> n 2) - (let* ((j (truncate n 2)) - (a (astep j)) - (k (- n j)) - (b (astep k))) - (merge! a b predicate))) - ((= n 2) - (let ((x (car seq)) - (y (cadr seq)) - (p seq)) - (setf seq (cddr seq)) - (when (funcall predicate y x) - (setf (car p) y) - (setf (cadr p) x)) - (setf (cddr p) nil) - p)) - ((= n 1) - (let ((p seq)) - (setf seq (cdr seq)) - (setf (cdr p) nil) - p)) - (t nil)))) - (astep (length seq)))) - -;;; CLOS/MOP -(defun list-indirect-class-methods (class) - "List all indirect methods of CLASS." - (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class)))) - -(defun list-class-methods (class methods &optional indirect) - "List all methods specializing on CLASS modulo METHODS. When INDIRECT is -non-nil, also include indirect (parent) methods." - (if (eq methods t) - (if indirect - (list-indirect-class-methods class) - (specializer-direct-generic-functions class)) - (mapcar - (lambda (s) - (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name))) - methods))) - -;; FIX 2023-09-13: need exclude param -(defun list-class-slots (class slots &optional exclude) - ;; should probably convert slot-definition-name here - (let ((cs (remove-if - (lambda (s) - (or - (null s) - (member t (mapcar - (lambda (x) - (string= (slot-definition-name s) x)) - exclude)))) - (class-slots class)))) - (if (eq slots t) - cs - (loop for s in slots - with sn = (symb s) - for c in cs - with cn = (symb (slot-definition-name c)) - when (eq sn cn) - collect c)))) - -;; TODO 2023-09-09: slot exclusion from dynamic var -(defun list-slot-values-using-class (class obj slots &optional nullp unboundp) - (remove-if - #'null - (mapcar - (lambda (s) - (let ((n (slot-definition-name s))) - (let ((ns (make-keyword (symbol-name n)))) - (if (slot-boundp-using-class class obj s) - (let ((v (slot-value-using-class class obj s))) - (if nullp - `(,ns ,v) - (unless (null v) - `(,ns ,v)))) - (when unboundp (list ns)))))) - slots))) - -;;; Seq utils - -(deftype signed-array-length () - "A (possibly negated) array length." - '#.(let ((limit (1- array-dimension-limit))) - `(integer ,(- limit) ,limit))) - -(defun take (n seq) - "Return, at most, the first N elements of SEQ, as a *new* sequence -of the same type as SEQ. - -If N is longer than SEQ, SEQ is simply copied. - -If N is negative, then |N| elements are taken (in their original -order) from the end of SEQ." - #+sbcl (declare (sb-ext:muffle-conditions style-warning)) - (declare (type signed-array-length n)) - (seq-dispatch seq - (if (minusp n) - (last seq (abs n)) - (firstn n seq)) - (if (minusp n) - (subseq seq (max 0 (+ (length seq) n))) - (subseq seq 0 (min n (length seq)))))) - -;;; Hashtable utils -(declaim (inline maphash-keys)) -(defun maphash-keys (function table) - "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE." - (maphash (lambda (k v) - (declare (ignore v)) - (funcall function k)) - table)) - -(declaim (inline maphash-values)) -(defun maphash-values (function table) - "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE." - (maphash (lambda (k v) - (declare (ignore k)) - (funcall function v)) - table)) - -(defun hash-table-keys (table) - "Returns a list containing the keys of hash table TABLE." - (let ((keys nil)) - (maphash-keys (lambda (k) - (push k keys)) - table) - keys)) - -(defun hash-table-values (table) - "Returns a list containing the values of hash table TABLE." - (let ((values nil)) - (maphash-values (lambda (v) - (push v values)) - table) - values)) - -(defun current-lisp-implementation () - "Return the current lisp implemenation as a cons: (TYPE VERSION)" - (list - (lisp-implementation-type) - (lisp-implementation-version) - *features*)) - -;;; Franz -(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) - -(defmacro if* (&rest args) - (do ((xx (reverse args) (cdr xx)) - (state :init) - (elseseen nil) - (totalcol nil) - (lookat nil nil) - (col nil)) - ((null xx) - (cond ((eq state :compl) - `(cond ,@totalcol)) - (t (error "if*: illegal form ~s" args)))) - (cond ((and (symbolp (car xx)) - (member (symbol-name (car xx)) - if*-keyword-list - :test #'string-equal)) - (setq lookat (symbol-name (car xx))))) - - (cond ((eq state :init) - (cond (lookat (cond ((string-equal lookat "thenret") - (setq col nil - state :then)) - (t (error - "if*: bad keyword ~a" lookat)))) - (t (setq state :col - col nil) - (push (car xx) col)))) - ((eq state :col) - (cond (lookat - (cond ((string-equal lookat "else") - (cond (elseseen - (error - "if*: multiples elses"))) - (setq elseseen t) - (setq state :init) - (push `(t ,@col) totalcol)) - ((string-equal lookat "then") - (setq state :then)) - (t (error "if*: bad keyword ~s" - lookat)))) - (t (push (car xx) col)))) - ((eq state :then) - (cond (lookat - (error - "if*: keyword ~s at the wrong place " (car xx))) - (t (setq state :compl) - (push `(,(car xx) ,@col) totalcol)))) - ((eq state :compl) - (cond ((not (string-equal lookat "elseif")) - (error "if*: missing elseif clause "))) - (setq state :init))))) - -(defun tmpfile (size) - "Create an anonymous temporary file of the given size. Returns a file descriptor." - (let (done fd pathname) - (unwind-protect - (progn - (setf (values fd pathname) (sb-posix:mkstemp "/dev/shm/tmp.XXXXXXXX")) - (sb-posix:unlink pathname) - (sb-posix:ftruncate fd size) - (setf done t)) - (when (and fd (not done)) (sb-posix:close fd))) - fd)) - -;;; Alexandria Functions -(declaim (inline ensure-function)) - -(declaim (ftype (function (t) (values function &optional)) - ensure-function)) -(defun ensure-function (function-designator) - "Returns the function designated by FUNCTION-DESIGNATOR: -if FUNCTION-DESIGNATOR is a function, it is returned, otherwise -it must be a function name and its FDEFINITION is returned." - (if (functionp function-designator) - function-designator - (fdefinition function-designator))) - -(define-modify-macro ensure-functionf/1 () ensure-function) - -(defmacro ensure-functionf (&rest places) - "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of -PLACES contains a function." - `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) - -(defun disjoin (predicate &rest more-predicates) - "Returns a function that applies each of PREDICATE and MORE-PREDICATE -functions in turn to its arguments, returning the primary value of the first -predicate that returns true, without calling the remaining predicates. -If none of the predicates returns true, NIL is returned." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((predicate (ensure-function predicate)) - (more-predicates (mapcar #'ensure-function more-predicates))) - (lambda (&rest arguments) - (or (apply predicate arguments) - (some (lambda (p) - (declare (type function p)) - (apply p arguments)) - more-predicates))))) - -(defun conjoin (predicate &rest more-predicates) - "Returns a function that applies each of PREDICATE and MORE-PREDICATE -functions in turn to its arguments, returning NIL if any of the predicates -returns false, without calling the remaining predicates. If none of the -predicates returns false, returns the primary value of the last predicate." - (if (null more-predicates) - predicate - (lambda (&rest arguments) - (and (apply predicate arguments) - ;; Cannot simply use CL:EVERY because we want to return the - ;; non-NIL value of the last predicate if all succeed. - (do ((tail (cdr more-predicates) (cdr tail)) - (head (car more-predicates) (car tail))) - ((not tail) - (apply head arguments)) - (unless (apply head arguments) - (return nil))))))) - -(defun compose (function &rest more-functions) - "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its -arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS, -and then calling the next one with the primary value of the last." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (reduce (lambda (f g) - (let ((f (ensure-function f)) - (g (ensure-function g))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - (funcall f (apply g arguments))))) - more-functions - :initial-value function)) - -(define-compiler-macro compose (function &rest more-functions) - (labels ((compose-1 (funs) - (if (cdr funs) - `(funcall ,(car funs) ,(compose-1 (cdr funs))) - `(apply ,(car funs) arguments)))) - (let* ((args (cons function more-functions)) - (funs (make-gensym-list (length args) "COMPOSE"))) - `(let ,(loop for f in funs for arg in args - collect `(,f (ensure-function ,arg))) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - ,(compose-1 funs)))))) - -(defun multiple-value-compose (function &rest more-functions) - "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies -its arguments to each in turn, starting from the rightmost of -MORE-FUNCTIONS, and then calling the next one with all the return values of -the last." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (reduce (lambda (f g) - (let ((f (ensure-function f)) - (g (ensure-function g))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - (multiple-value-call f (apply g arguments))))) - more-functions - :initial-value function)) - -(define-compiler-macro multiple-value-compose (function &rest more-functions) - (labels ((compose-1 (funs) - (if (cdr funs) - `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs))) - `(apply ,(car funs) arguments)))) - (let* ((args (cons function more-functions)) - (funs (make-gensym-list (length args) "MV-COMPOSE"))) - `(let ,(mapcar #'list funs args) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - ,(compose-1 funs)))))) - -(declaim (inline curry rcurry)) - -(defun curry (function &rest arguments) - "Returns a function that applies ARGUMENTS and the arguments -it is called with to FUNCTION." - (declare (optimize (speed 3) (safety 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - ;; Using M-V-C we don't need to append the arguments. - (multiple-value-call fn (values-list arguments) (values-list more))))) - -(define-compiler-macro curry (function &rest arguments) - (let ((curries (make-gensym-list (length arguments) "CURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list curries arguments)) - (declare (optimize (speed 3) (safety 1))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (apply ,fun ,@curries more))))) - -(defun rcurry (function &rest arguments) - "Returns a function that applies the arguments it is called -with and ARGUMENTS to FUNCTION." - (declare (optimize (speed 3) (safety 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call fn (values-list more) (values-list arguments))))) - -(define-compiler-macro rcurry (function &rest arguments) - (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list rcurries arguments)) - (declare (optimize (speed 3) (safety 1))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call ,fun (values-list more) ,@rcurries))))) - -(declaim (notinline curry rcurry)) - - -(defmacro named-lambda (name lambda-list &body body) - "Expands into a lambda-expression within whose BODY NAME denotes the -corresponding function." - `(labels ((,name ,lambda-list ,@body)) - #',name)) - -;;; array utils - -(defun copy-array (array) - (let ((new-array - (make-array (array-dimensions array) - :element-type (array-element-type array) - :adjustable (adjustable-array-p array) - :fill-pointer (and (array-has-fill-pointer-p array) - (fill-pointer array))))) - (loop for i below (array-total-size array) - do (setf (row-major-aref new-array i) - (row-major-aref array i))) - new-array)) - -;;; hash-table utils -(defun hash-table-alist (table) - "Returns an association list containing the keys and values of hash table -TABLE." - (let ((alist nil)) - (maphash (lambda (k v) - (push (cons k v) alist)) - table) - alist)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/fu/curry.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/fu/curry.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,159 @@ +;;; std/fu/curry.lisp --- Standard Currying Functors + +;; + +;;; Code: +(in-package :std/fu) + +;;; Alexandria Functions +(declaim (inline ensure-function)) + +(declaim (ftype (function (t) (values function &optional)) + ensure-function)) +(defun ensure-function (function-designator) + "Returns the function designated by FUNCTION-DESIGNATOR: +if FUNCTION-DESIGNATOR is a function, it is returned, otherwise +it must be a function name and its FDEFINITION is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + +(define-modify-macro ensure-functionf/1 () ensure-function) + +(defmacro ensure-functionf (&rest places) + "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of +PLACES contains a function." + `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) + +(defun disjoin (predicate &rest more-predicates) + "Returns a function that applies each of PREDICATE and MORE-PREDICATE +functions in turn to its arguments, returning the primary value of the first +predicate that returns true, without calling the remaining predicates. +If none of the predicates returns true, NIL is returned." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((predicate (ensure-function predicate)) + (more-predicates (mapcar #'ensure-function more-predicates))) + (lambda (&rest arguments) + (or (apply predicate arguments) + (some (lambda (p) + (declare (type function p)) + (apply p arguments)) + more-predicates))))) + +(defun conjoin (predicate &rest more-predicates) + "Returns a function that applies each of PREDICATE and MORE-PREDICATE +functions in turn to its arguments, returning NIL if any of the predicates +returns false, without calling the remaining predicates. If none of the +predicates returns false, returns the primary value of the last predicate." + (if (null more-predicates) + predicate + (lambda (&rest arguments) + (and (apply predicate arguments) + ;; Cannot simply use CL:EVERY because we want to return the + ;; non-NIL value of the last predicate if all succeed. + (do ((tail (cdr more-predicates) (cdr tail)) + (head (car more-predicates) (car tail))) + ((not tail) + (apply head arguments)) + (unless (apply head arguments) + (return nil))))))) + +(defun compose (function &rest more-functions) + "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its +arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS, +and then calling the next one with the primary value of the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (funcall f (apply g arguments))))) + more-functions + :initial-value function)) + +(define-compiler-macro compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(funcall ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "COMPOSE"))) + `(let ,(loop for f in funs for arg in args + collect `(,f (ensure-function ,arg))) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + +(defun multiple-value-compose (function &rest more-functions) + "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies +its arguments to each in turn, starting from the rightmost of +MORE-FUNCTIONS, and then calling the next one with all the return values of +the last." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (reduce (lambda (f g) + (let ((f (ensure-function f)) + (g (ensure-function g))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + (multiple-value-call f (apply g arguments))))) + more-functions + :initial-value function)) + +(define-compiler-macro multiple-value-compose (function &rest more-functions) + (labels ((compose-1 (funs) + (if (cdr funs) + `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs))) + `(apply ,(car funs) arguments)))) + (let* ((args (cons function more-functions)) + (funs (make-gensym-list (length args) "MV-COMPOSE"))) + `(let ,(mapcar #'list funs args) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest arguments) + (declare (dynamic-extent arguments)) + ,(compose-1 funs)))))) + +(declaim (inline curry rcurry)) + +(defun curry (function &rest arguments) + "Returns a function that applies ARGUMENTS and the arguments +it is called with to FUNCTION." + (declare (optimize (speed 3) (safety 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + +(define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (apply ,fun ,@curries more))))) + +(defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and ARGUMENTS to FUNCTION." + (declare (optimize (speed 3) (safety 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + +(define-compiler-macro rcurry (function &rest arguments) + (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list rcurries arguments)) + (declare (optimize (speed 3) (safety 1))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call ,fun (values-list more) ,@rcurries))))) + +(declaim (notinline curry rcurry)) + diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/hash-table.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/hash-table.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,47 @@ +;;; std/hash-table.lisp --- Standard Hash Tables + +;; + +;;; Code: +(in-package :std/hash-table) + +(declaim (inline maphash-keys)) +(defun maphash-keys (function table) + "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE." + (maphash (lambda (k v) + (declare (ignore v)) + (funcall function k)) + table)) + +(declaim (inline maphash-values)) +(defun maphash-values (function table) + "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE." + (maphash (lambda (k v) + (declare (ignore k)) + (funcall function v)) + table)) + +(defun hash-table-keys (table) + "Returns a list containing the keys of hash table TABLE." + (let ((keys nil)) + (maphash-keys (lambda (k) + (push k keys)) + table) + keys)) + +(defun hash-table-values (table) + "Returns a list containing the values of hash table TABLE." + (let ((values nil)) + (maphash-values (lambda (v) + (push v values)) + table) + values)) + +(defun hash-table-alist (table) + "Returns an association list containing the keys and values of hash table +TABLE." + (let ((alist nil)) + (maphash (lambda (k v) + (push (cons k v) alist)) + table) + alist)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/list.lisp --- a/lisp/std/list.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/list.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -1,7 +1,7 @@ ;;; std/list.lisp --- List utils ;;; Code: -(in-package :std) +(in-package :std/list) ;; (reexport-from :sb-int ;; :include '(:recons :memq :assq :ensure-list :proper-list-of-length-p :proper-list-p @@ -122,3 +122,60 @@ (car x) (rec (cdr x) acc)))))) (rec x nil)))) + +;;; cl-bench utils +;; Destructive merge of two sorted lists. +;; From Hansen's MS thesis. +(defun merge! (a b predicate) + (labels ((merge-loop (r a b) + (cond ((funcall predicate (car b) (car a)) + (setf (cdr r) b) + (if (null (cdr b)) + (setf (cdr b) a) + (merge-loop b a (cdr b)))) + (t ; (car a) <= (car b) + (setf (cdr r) a) + (if (null (cdr a)) + (setf (cdr a) b) + (merge-loop a (cdr a) b)))))) + (cond ((null a) b) + ((null b) a) + ((funcall predicate (car b) (car a)) + (if (null (cdr b)) + (setf (cdr b) a) + (merge-loop b a (cdr b))) + b) + (t ; (car a) <= (car b) + (if (null (cdr a)) + (setf (cdr a) b) + (merge-loop a (cdr a) b)) + a)))) + +;; Stable sort procedure which copies the input list and then sorts +;; the new list imperatively. Due to Richard O'Keefe; algorithm +;; attributed to D.H.D. Warren. +(defun sort! (seq predicate) + (labels ((astep (n) + (cond ((> n 2) + (let* ((j (truncate n 2)) + (a (astep j)) + (k (- n j)) + (b (astep k))) + (merge! a b predicate))) + ((= n 2) + (let ((x (car seq)) + (y (cadr seq)) + (p seq)) + (setf seq (cddr seq)) + (when (funcall predicate y x) + (setf (car p) y) + (setf (cadr p) x)) + (setf (cddr p) nil) + p)) + ((= n 1) + (let ((p seq)) + (setf seq (cdr seq)) + (setf (cdr p) nil) + p)) + (t nil)))) + (astep (length seq)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/macs/ana.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/macs/ana.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,671 @@ +;;; ana.lisp --- anaphoric macros + +;;; Code: +(in-package :std/macs) + +(in-readtable :std) + +;;; Named Lambdas +;; (reexport-from :sb-int :include '(:make-macro-lambda :parse-lambda-list)) + +;; LoL tlist +;; (declaim (inline make-tlist tlist-left +;; tlist-right tlist-empty-p)) + +;; (defun make-tlist () (cons nil nil)) +;; (defun tlist-left (tl) (caar tl)) +;; (defun tlist-right (tl) (cadr tl)) +;; (defun tlist-empty-p (tl) (null (car tl))) + +;; (declaim (inline tlist-add-left +;; tlist-add-right)) + +;; (defun tlist-add-left (tl it) +;; (let ((x (cons it (car tl)))) +;; (if (tlist-empty-p tl) +;; (setf (cdr tl) x)) +;; (setf (car tl) x))) + +;; (defun tlist-add-right (tl it) +;; (let ((x (cons it nil))) +;; (if (tlist-empty-p tl) +;; (setf (car tl) x) +;; (setf (cddr tl) x)) +;; (setf (cdr tl) x))) + +;; (declaim (inline tlist-rem-left)) + +;; (defun tlist-rem-left (tl) +;; (if (tlist-empty-p tl) +;; (error "Remove from empty tlist") +;; (let ((x (car tl))) +;; (setf (car tl) (cdar tl)) +;; (if (tlist-empty-p tl) +;; (setf (cdr tl) nil)) ;; For gc +;; (car x)))) + +;; (declaim (inline tlist-update)) + +;; (defun tlist-update (tl) +;; (setf (cdr tl) (last (car tl)))) + +(defun build-batcher-sn (n) + (let* (network + (tee (ceiling (log n 2))) + (p (ash 1 (- tee 1)))) + (loop while (> p 0) do + (let ((q (ash 1 (- tee 1))) + (r 0) + (d p)) + (loop while (> d 0) do + (loop for i from 0 to (- n d 1) do + (if (= (logand i p) r) + (push (list i (+ i d)) + network))) + (setf d (- q p) + q (ash q -1) + r p))) + (setf p (ash p -1))) + (nreverse network))) + +(defmacro! sortf (comparator &rest places) + (if places + `(tagbody + ,@(mapcar + #`(let ((,g!a #1=,(nth (car a1) places)) + (,g!b #2=,(nth (cadr a1) places))) + (if (,comparator ,g!b ,g!a) + (setf #1# ,g!b + #2# ,g!a))) + (build-batcher-sn (length places)))))) + +#+cl-ppcre +(defun dollar-symbol-p (s) + (and (symbolp s) + (> (length (symbol-name s)) 1) + (string= (symbol-name s) + "$" + :start1 0 + :end1 1) + (ignore-errors (parse-integer (subseq (symbol-name s) 1))))) + + +#+cl-ppcre +(defmacro! if-match ((match-regex str) then &optional else) + (let* ((dollars (remove-duplicates + (remove-if-not #'dollar-symbol-p + (flatten then)))) + (top (or (car (sort (mapcar #'dollar-symbol-p dollars) #'>)) + 0))) + `(multiple-value-bind (,g!matches ,g!captures) (,match-regex ,str) + (declare (ignorable ,g!matches ,g!captures)) + (let ((,g!captures-len (length ,g!captures))) + (declare (ignorable ,g!captures-len)) + (symbol-macrolet ,(mapcar #`(,(symb "$" a1) + (if (< ,g!captures-len ,a1) + (error "Too few matchs: ~a unbound." ,(mkstr "$" a1)) + (aref ,g!captures ,(1- a1)))) + (loop for i from 1 to top collect i)) + (if ,g!matches + ,then + ,else)))))) + +(defun g!-symbol-p (s) + (and (symbolp s) + (> (length (symbol-name s)) 2) + (string= (symbol-name s) + "G!" + :start1 0 + :end1 2))) + +(defun o!-symbol-p (s) + (and (symbolp s) + (> (length (symbol-name s)) 2) + (string= (symbol-name s) + "O!" + :start1 0 + :end1 2))) + +(defun o!-symbol-to-g!-symbol (s) + (symb "G!" + (subseq (symbol-name s) 2))) + +#+cl-ppcre +(defmacro when-match ((match-regex str) &body forms) + `(if-match (,match-regex ,str) + (progn ,@forms))) + +(defmacro once-only (specs &body forms) + "Constructs code whose primary goal is to help automate the handling of +multiple evaluation within macros. Multiple evaluation is handled by introducing +intermediate variables, in order to reuse the result of an expression. + +The returned value is a list of the form + + (let (( ) + ... + ( )) + ) + +where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order +to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of +evaluating the implicit progn FORMS within a special context determined by +SPECS. RES should make use of (reference) the intermediate variables. + +Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM). +Bare symbols are equivalent to the pair (SYMBOL SYMBOL). + +Each pair (SYMBOL INITFORM) specifies a single intermediate variable: + +- INITFORM is an expression evaluated to produce EXPR-i + +- SYMBOL is the name of the variable that will be bound around FORMS to the + corresponding gensym GENSYM-i, in order for FORMS to generate RES that + references the intermediate variable + +The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of +all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. + +Example: + + The following expression + + (let ((x '(incf y))) + (once-only (x) + `(cons ,x ,x))) + + ;;; => + ;;; (let ((#1=#:X123 (incf y))) + ;;; (cons #1# #1#)) + + could be used within a macro to avoid multiple evaluation like so + + (defmacro cons1 (x) + (once-only (x) + `(cons ,x ,x))) + + (let ((y 0)) + (cons1 (incf y))) + + ;;; => (1 . 1) + +Example: + + The following expression demonstrates the usage of the INITFORM field + + (let ((expr '(incf y))) + (once-only ((var `(1+ ,expr))) + `(list ',expr ,var ,var))) + + ;;; => + ;;; (let ((#1=#:VAR123 (1+ (incf y)))) + ;;; (list '(incf y) #1# #1)) + + which could be used like so + + (defmacro print-succ-twice (expr) + (once-only ((var `(1+ ,expr))) + `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) + + (let ((y 10)) + (print-succ-twice (incf y))) + + ;;; >> + ;;; Expr: (INCF Y), Once: 12, Twice: 12" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + +;;;; DESTRUCTURING-*CASE + +(defun expand-destructuring-case (key clauses case) + (once-only (key) + `(if (typep ,key 'cons) + (,case (car ,key) + ,@(mapcar (lambda (clause) + (destructuring-bind ((keys . lambda-list) &body body) clause + `(,keys + (destructuring-bind ,lambda-list (cdr ,key) + ,@body)))) + clauses)) + (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) + +(defmacro destructuring-case (keyform &body clauses) + "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND. +KEYFORM must evaluate to a CONS. + +Clauses are of the form: + + ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) + +The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE, +is selected, and FORMs are then executed with CDR of KEY is destructured and +bound by the DESTRUCTURING-LAMBDA-LIST. + +Example: + + (defun dcase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar: ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)) + ((t &rest rest) + (format nil \"unknown: ~S\" rest)))) + + (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" + (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (dcase (list :alt1 1)) ; => \"alt: 1\" + (dcase (list :alt2 2)) ; => \"alt: 2\" + (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" + + (defun decase (x) + (destructuring-case x + ((:foo a b) + (format nil \"foo: ~S, ~S\" a b)) + ((:bar &key a b) + (format nil \"bar: ~S, ~S\" a b)) + (((:alt1 :alt2) a) + (format nil \"alt: ~S\" a)))) + + (decase (list :foo 1 2)) ; => \"foo: 1, 2\" + (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" + (decase (list :alt1 1)) ; => \"alt: 1\" + (decase (list :alt2 2)) ; => \"alt: 2\" + (decase (list :quux 1 2 3)) ; =| error +" + (expand-destructuring-case keyform clauses 'case)) + +(defmacro destructuring-ccase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ccase)) + +(defmacro destructuring-ecase (keyform &body clauses) + (expand-destructuring-case keyform clauses 'ecase)) + +(dolist (name '(destructuring-ccase destructuring-ecase)) + (setf (documentation name 'function) (documentation 'destructuring-case 'function))) + +;;; *-let --- control-flow let-binding macros +;; based on https://stevelosh.com/blog/2018/07/fun-with-macros-if-let/ + +(defmacro when-let (bindings &body body) + "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`. + + This macro combines `when` and `let`. It takes a list of bindings and + binds them like `let` before executing `body`, but if any binding's value + evaluates to `nil` the process stops and `nil` is immediately returned. + + Examples: + + (when-let ((a (progn (print :a) 1)) + (b (progn (print :b) 2)) + (list a b)) + ; => + :A + :B + (1 2) + + (when-let ((a (progn (print :a) nil)) + (b (progn (print :b) 2))) + (list a b)) + ; => + :A + NIL + + " + (with-gensyms (block) + `(block ,block + (let ,(loop :for (symbol value) :in bindings + :collect `(,symbol (or ,value + (return-from ,block nil)))) + ,@body)))) + +(defmacro when-let* (bindings &body body) + "Bind `bindings` serially and execute `body`, short-circuiting on `nil`. + + This macro combines `when` and `let*`. It takes a list of bindings + and binds them like `let*` before executing `body`, but if any + binding's value evaluates to `nil` the process stops and `nil` is + immediately returned. + + Examples: + + (when-let* ((a (progn (print :a) 1)) + (b (progn (print :b) (1+ a))) + (list a b)) + ; => + :A + :B + (1 2) + + (when-let* ((a (progn (print :a) nil)) + (b (progn (print :b) (1+ a)))) + (list a b)) + ; => + :A + NIL + + " + (with-gensyms (block) + `(block ,block + (let* ,(loop :for (symbol value) :in bindings + :collect `(,symbol (or ,value + (return-from ,block nil)))) + ,@body)))) + +(defmacro if-let (bindings &body body) + "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise. + + `body` must be of the form `(...optional-declarations... then else)`. + + This macro combines `if` and `let`. It takes a list of bindings and + binds them like `let` before executing the `then` branch of `body`, but + if any binding's value evaluates to `nil` the process stops there and the + `else` branch is immediately executed (with no bindings in effect). + + If any `optional-declarations` are included they will only be in effect + for the `then` branch. + + Examples: + + (if-let ((a (progn (print :a) 1)) + (b (progn (print :b) 2))) + (list a b) + 'nope) + ; => + :A + :B + (1 2) + + (if-let ((a (progn (print :a) nil)) + (b (progn (print :b) 2))) + (list a b) + 'nope) + ; => + :A + NOPE + + " + (with-gensyms (outer inner) + (multiple-value-bind (body declarations) (parse-body body) + (destructuring-bind (then else) body + `(block ,outer + (block ,inner + (let ,(loop :for (symbol value) :in bindings + :collect `(,symbol (or ,value + (return-from ,inner nil)))) + ,@declarations + (return-from ,outer ,then))) + ,else))))) + +(defmacro if-let* (bindings then else) + "Bind `bindings` serially and execute `then` if all are true, or `else` otherwise. + + This macro combines `if` and `let*`. It takes a list of bindings and + binds them like `let*` before executing `then`, but if any binding's + value evaluates to `nil` the process stops and the `else` branch is + immediately executed (with no bindings in effect). + + Examples: + + (if-let* ((a (progn (print :a) 1)) + (b (progn (print :b) (1+ a))) + (list a b) + 'nope) + ; => + :A + :B + (1 2) + + (if-let* ((a (progn (print :a) nil)) + (b (progn (print :b) (1+ a)))) + (list a b) + 'nope) + ; => + :A + NOPE + + " + (with-gensyms (outer inner) + `(block ,outer + (block ,inner + (let* ,(loop :for (symbol value) :in bindings + :collect `(,symbol (or ,value + (return-from ,inner nil)))) + (return-from ,outer ,then))) + ,else))) + + +(defmacro def! (name &body body) + "`defun' without args." + `(defun ,name () ,@body)) + +(defmacro eval-always (&body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) + +;;; Franz +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + +(defmacro named-lambda (name lambda-list &body body) + "Expands into a lambda-expression within whose BODY NAME denotes the +corresponding function." + `(labels ((,name ,lambda-list ,@body)) + #',name)) + +;;; Misc +(defmacro until (condition &body body) + (let ((block-name (gensym))) + `(block ,block-name + (loop + (if ,condition + (return-from ,block-name nil) + (progn ,@body)))))) + +(defmacro defmacro/g! (name args &rest body) + (let ((syms (remove-duplicates + (remove-if-not #'g!-symbol-p + (flatten body))))) + (multiple-value-bind (body declarations docstring) + (parse-body body :documentation t) + `(defmacro ,name ,args + ,@(when docstring + (list docstring)) + ,@declarations + (let ,(mapcar + (lambda (s) + `(,s (gensym ,(subseq + (symbol-name s) + 2)))) + syms) + ,@body))))) + +(defmacro defmacro! (name args &rest body) + (let* ((os (remove-if-not #'o!-symbol-p (flatten args))) + (gs (mapcar #'o!-symbol-to-g!-symbol os))) + (multiple-value-bind (body declarations docstring) + (parse-body body :documentation t) + `(defmacro/g! ,name ,args + ,@(when docstring + (list docstring)) + ,@declarations + `(let ,(mapcar #'list (list ,@gs) (list ,@os)) + ,(progn ,@body)))))) + +(defmacro defun! (name args &body body) + (let ((syms (remove-duplicates + (remove-if-not #'g!-symbol-p + (flatten body))))) + (multiple-value-bind (body declarations docstring) + (parse-body body :documentation t) + `(defun ,name ,args + ,@(when docstring + (list docstring)) + ,@declarations + (let ,(mapcar (lambda (s) + `(,s (gensym ,(subseq (symbol-name s) + 2)))) + syms) + ,@body))))) + +(defmacro! dlambda (&rest ds) + "Dynamic dispatch lambda." + `(lambda (&rest ,g!args) + (case (car ,g!args) + ,@(mapcar + (lambda (d) + `(,(if (eq t (car d)) + t + (list (car d))) + (apply (lambda ,@(cdr d)) + ,(if (eq t (car d)) + g!args + `(cdr ,g!args))))) + ds)))) + +;; Graham's alambda +(defmacro alambda (parms &body body) + `(labels ((self ,parms ,@body)) + #'self)) + +;; Graham's aif +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +;; ;; TODO 2023-09-05: wrap, document, optimize, hack +;; re-exported from SB-INT +(defmacro awhen (test &body body) + `(let ((it ,test)) + (when it ,@body))) + +(defmacro acond (&rest clauses) + (if (null clauses) + `() + (destructuring-bind ((test &body body) &rest rest) clauses + (let ((it (copy-symbol 'it))) + `(let ((,it ,test)) + (if ,it + ;; Just like COND - no body means return the tested value. + ,(if body + `(let ((it ,it)) (declare (ignorable it)) ,@body) + it) + (acond ,@rest))))))) + +(defmacro! nlet-tail (n letargs &body body) + (let ((gs (loop for i in letargs + collect (gensym)))) + `(macrolet + ((,n ,gs + `(progn + (psetq + ,@(apply #'nconc + (mapcar + #'list + ',(mapcar #'car letargs) + (list ,@gs)))) + (go ,',g!n)))) + (block ,g!b + (let ,letargs + (tagbody + ,g!n (return-from + ,g!b (progn ,@body)))))))) + +(defmacro alet% (letargs &rest body) + `(let ((this) ,@letargs) + (setq this ,@(last body)) + ,@(butlast body) + this)) + +(defmacro alet (letargs &rest body) + `(let ((this) ,@letargs) + (setq this ,@(last body)) + ,@(butlast body) + (lambda (&rest params) + (apply this params)))) + +;; swiped from fiveam. This is just like acond except it assumes that +;; the TEST in each element of CLAUSES returns two values as opposed +;; to one. +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (with-gensyms (val foundp) + (destructuring-bind ((test &rest progn) &rest others) + clauses + `(multiple-value-bind (,val ,foundp) + ,test + (if (or ,val ,foundp) + (let ((it ,val)) + (declare (ignorable it)) + ,@progn) + (acond2 ,@others))))))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/macs/const.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/macs/const.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,46 @@ +;;; std/macs/const.lisp --- DEFINE-CONSTANT and friends + +;; + +;;; Code: +(in-package :std/macs) +;; (reexport-from :sb-c +;; :include '(:define-source-transformation +;; :parse-eval-when-situations +;; :source-location)) +;;; Definitions +(defun %reevaluate-constant (name value test) + (if (not (boundp name)) + value + (let ((old (symbol-value name)) + (new value)) + (if (not (constantp name)) + (prog1 new + (cerror "Try to redefine the variable as a constant." + "~@<~S is an already bound non-constant variable ~ + whose value is ~S.~:@>" name old)) + (if (funcall test old new) + old + (restart-case + (error "~@<~S is an already defined constant whose value ~ + ~S is not equal to the provided initial value ~S ~ + under ~S.~:@>" name old new test) + (ignore () + :report "Retain the current value." + old) + (continue () + :report "Try to redefine the constant." + new))))))) + +(defmacro define-constant (name initial-value &key (test #'eql) documentation) + "Ensures that the global variable named by NAME is a constant with a value +that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a +/function designator/ that defaults to EQL. If DOCUMENTATION is given, it +becomes the documentation string of the constant. + +Signals an error if NAME is already a bound non-constant variable. + +Signals an error if NAME is already a constant variable whose value is not +equal under TEST to result of evaluating INITIAL-VALUE." + `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) + ,@(when documentation `(,documentation)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/macs/pan.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/macs/pan.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,84 @@ +;;; pan.lisp --- Pandoric macros + +;;; Code: +(in-package :std) +(in-readtable :std) + +(defun pandoriclet-get (letargs) + `(case sym + ,@(mapcar #`(((car a1)) (car a1)) + letargs) + (t (error + "Unknown pandoric get: ~a" + sym)))) + +(defun pandoriclet-set (letargs) + `(case sym + ,@(mapcar #`(((car a1)) + (setq (car a1) val)) + letargs) + (t (error + "Unknown pandoric set: ~a" + sym)))) + +(defmacro pandoriclet (letargs &rest body) + (let ((letargs (cons + '(this) + (let-binding-transform + letargs)))) + `(let (,@letargs) + (setq this ,@(last body)) + ,@(butlast body) + (dlambda + (:pandoric-get (sym) + ,(pandoriclet-get letargs)) + (:pandoric-set (sym val) + ,(pandoriclet-set letargs)) + (t (&rest args) + (apply this args)))))) + +(declaim (inline get-pandoric)) + +(defun get-pandoric (box sym) + (funcall box :pandoric-get sym)) + +(defsetf get-pandoric (box sym) (val) + `(progn + (funcall ,box :pandoric-set ,sym ,val) + ,val)) + +(defmacro! with-pandoric (syms o!box &rest body) + `(symbol-macrolet + (,@(mapcar #`(a1 (get-pandoric ,g!box a1)) + syms)) + ,@body)) + +;; (defun pandoric-hotpatch (box new) +;; (with-pandoric (this) box +;; (setq this new))) + +(defmacro pandoric-recode (vars box new) + `(with-pandoric (this ,@vars) ,box + (setq this ,new))) + +(defmacro plambda (largs pargs &rest body) + (let ((pargs (mapcar #'list pargs))) + `(let (this self) + (setq + this (lambda ,largs ,@body) + self (dlambda + (:pandoric-get (sym) + ,(pandoriclet-get pargs)) + (:pandoric-set (sym val) + ,(pandoriclet-set pargs)) + (t (&rest args) + (apply this args))))))) + +(defvar pandoric-eval-tunnel) + +(defmacro pandoric-eval (vars expr) + `(let ((pandoric-eval-tunnel + (plambda () ,vars t))) + (eval `(with-pandoric + ,',vars pandoric-eval-tunnel + ,,expr)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/mop.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/mop.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,60 @@ +;;; std/mop.lisp --- Standard MOP + +;; + +;;; Code: +(in-package :std/mop) + +(defun list-indirect-class-methods (class) + "List all indirect methods of CLASS." + (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class)))) + +(defun list-class-methods (class methods &optional indirect) + "List all methods specializing on CLASS modulo METHODS. When INDIRECT is +non-nil, also include indirect (parent) methods." + (if (eq methods t) + (if indirect + (list-indirect-class-methods class) + (specializer-direct-generic-functions class)) + (mapcar + (lambda (s) + (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name))) + methods))) + +;; FIX 2023-09-13: need exclude param +(defun list-class-slots (class slots &optional exclude) + ;; should probably convert slot-definition-name here + (let ((cs (remove-if + (lambda (s) + (or + (null s) + (member t (mapcar + (lambda (x) + (string= (slot-definition-name s) x)) + exclude)))) + (class-slots class)))) + (if (eq slots t) + cs + (loop for s in slots + with sn = (symb s) + for c in cs + with cn = (symb (slot-definition-name c)) + when (eq sn cn) + collect c)))) + +;; TODO 2023-09-09: slot exclusion from dynamic var +(defun list-slot-values-using-class (class obj slots &optional nullp unboundp) + (remove-if + #'null + (mapcar + (lambda (s) + (let ((n (slot-definition-name s))) + (let ((ns (make-keyword (symbol-name n)))) + (if (slot-boundp-using-class class obj s) + (let ((v (slot-value-using-class class obj s))) + (if nullp + `(,ns ,v) + (unless (null v) + `(,ns ,v)))) + (when unboundp (list ns)))))) + slots))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/named-readtables.lisp --- a/lisp/std/named-readtables.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/named-readtables.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -12,30 +12,6 @@ ;; behavior (using standard) versus your source code (custom). ;;; Code: -(uiop:define-package :std/named-readtables - (:use :cl) - (:export - #:defreadtable - #:in-readtable - #:make-readtable - #:merge-readtables-into - #:find-readtable - #:ensure-readtable - #:rename-readtable - #:readtable-name - #:register-readtable - #:unregister-readtable - #:copy-named-readtable - #:list-all-named-readtables - ;; Types - #:named-readtable-designator - ;; Conditions - #:readtable-error - #:reader-macro-conflict - #:readtable-does-already-exist - #:readtable-does-not-exist - #:parse-body)) - (in-package :std/named-readtables) (pushnew :named-readtables *features*) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/num/float.lisp --- a/lisp/std/num/float.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/num/float.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -9,7 +9,7 @@ ;;; ;;; See http://common-lisp.net/project/ieee-floats/ -(in-package :std) +(in-package :std/num) ;; The following macro may look a bit overcomplicated to the casual ;; reader. The main culprit is the fact that NaN and infinity can be diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/num/parse.lisp --- a/lisp/std/num/parse.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/num/parse.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,7 @@ ;; ;;; Code: -(in-package :std) +(in-package :std/num) (define-condition invalid-number (parse-error) ((value :reader invalid-number-value diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/os.lisp --- a/lisp/std/os.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/os.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,7 @@ ;; UNIX only. ;;; Code: -(in-package :std) +(in-package :std/os) (require 'sb-posix) (defun list-all-users () diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/pan.lisp --- a/lisp/std/pan.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -;;; pan.lisp --- Pandoric macros - -;;; Code: -(in-package :std) -(in-readtable :std) - -(defun pandoriclet-get (letargs) - `(case sym - ,@(mapcar #`(((car a1)) (car a1)) - letargs) - (t (error - "Unknown pandoric get: ~a" - sym)))) - -(defun pandoriclet-set (letargs) - `(case sym - ,@(mapcar #`(((car a1)) - (setq (car a1) val)) - letargs) - (t (error - "Unknown pandoric set: ~a" - sym)))) - -(defmacro pandoriclet (letargs &rest body) - (let ((letargs (cons - '(this) - (let-binding-transform - letargs)))) - `(let (,@letargs) - (setq this ,@(last body)) - ,@(butlast body) - (dlambda - (:pandoric-get (sym) - ,(pandoriclet-get letargs)) - (:pandoric-set (sym val) - ,(pandoriclet-set letargs)) - (t (&rest args) - (apply this args)))))) - -(declaim (inline get-pandoric)) - -(defun get-pandoric (box sym) - (funcall box :pandoric-get sym)) - -(defsetf get-pandoric (box sym) (val) - `(progn - (funcall ,box :pandoric-set ,sym ,val) - ,val)) - -(defmacro! with-pandoric (syms o!box &rest body) - `(symbol-macrolet - (,@(mapcar #`(a1 (get-pandoric ,g!box a1)) - syms)) - ,@body)) - -;; (defun pandoric-hotpatch (box new) -;; (with-pandoric (this) box -;; (setq this new))) - -(defmacro pandoric-recode (vars box new) - `(with-pandoric (this ,@vars) ,box - (setq this ,new))) - -(defmacro plambda (largs pargs &rest body) - (let ((pargs (mapcar #'list pargs))) - `(let (this self) - (setq - this (lambda ,largs ,@body) - self (dlambda - (:pandoric-get (sym) - ,(pandoriclet-get pargs)) - (:pandoric-set (sym val) - ,(pandoriclet-set pargs)) - (t (&rest args) - (apply this args))))))) - -(defvar pandoric-eval-tunnel) - -(defmacro pandoric-eval (vars expr) - `(let ((pandoric-eval-tunnel - (plambda () ,vars t))) - (eval `(with-pandoric - ,',vars pandoric-eval-tunnel - ,,expr)))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/path.lisp --- a/lisp/std/path.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/path.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,7 @@ ;; ;;; Code: -(in-package :std) +(in-package :std/path) (deftype wild-pathname () "A pathname with wild components." diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/pkg.lisp --- a/lisp/std/pkg.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/pkg.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -1,17 +1,56 @@ (pushnew :std *features*) (pushnew "STD" *modules* :test 'equal) -(uiop:define-package :std - (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien :sb-gray :sb-concurrency) - (:use-reexport :std/named-readtables) - (:shadowing-import-from :uiop :println) - (:shadowing-import-from - :sb-int - :ensure-list :recons :memq :assq :ensure-list - :proper-list-of-length-p :proper-list-p :singleton-p - :with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*) + +(defpackage :std/named-readtables + (:use :cl) (:export - ;; types - ;; err + :defreadtable + :in-readtable + :make-readtable + :merge-readtables-into + :find-readtable + :ensure-readtable + :rename-readtable + :readtable-name + :register-readtable + :unregister-readtable + :copy-named-readtable + :list-all-named-readtables + ;; Types + :named-readtable-designator + ;; Conditions + :readtable-error + :reader-macro-conflict + :readtable-does-already-exist + :readtable-does-not-exist + :parse-body)) + +(defpackage :std/defpkg + (:use :cl) + (:nicknames :pkg) + (:export :defpkg + :find-package* :find-symbol* :symbol-call + :intern* :export* :import* :shadowing-import* + :shadow* :make-symbol* :unintern* + :symbol-shadowing-p :home-package-p + :symbol-package-name :standard-common-lisp-symbol-p + :reify-package :unreify-package :reify-symbol :unreify-symbol + :nuke-symbol-in-package :nuke-symbol :rehome-symbol + :ensure-package-unused :delete-package* + :package-names :packages-from-names :fresh-package-name + :rename-package-away :package-definition-form :parse-defpkg-form + :ensure-package)) + +(defpackage :std-user + (:use :cl :std/named-readtables :std/defpkg) + (:shadowing-import-from :std/defpkg :defpkg) + (:export :defpkg :in-readtable)) + +(in-package :std-user) + +(defpkg :std/err + (:use :cl) + (:export ;; err :std-error :std-error-message :define-error-reporter :deferror @@ -35,7 +74,60 @@ :invalid-argument-item :invalid-argument-reason :invalid-argument-p - :unwind-protect-case + :unwind-protect-case)) + +(defpkg :std/sym + (:use :cl) + (:shadowing-import-from :sb-int + :with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify* + :gensymify) + (:export + :ensure-symbol + :format-symbol + :make-keyword + :make-slot-name + :make-gensym + :make-gensym-list + :with-gensyms + :with-unique-names + :symbolicate + :keywordicate + :gensymify + :gensymify*)) + +(defpkg :std/list + (:use :cl) + (:shadowing-import-from :sb-int + :ensure-list :recons :memq :assq + :ensure-list :proper-list-of-length-p :proper-list-p :singleton-p) + (:export + :ensure-car + :ensure-cons + :appendf + :nconcf + :unionf + :nunionf + :reversef + :nreversef + :deletef + :flatten + :group + :let-binding-transform + :ensure-list :recons :memq :assq + :circular-list :circular-list-p :circular-tree-p :merge! + :sort!)) + +(defpkg :std/type + (:use :cl) + (:import-from :std/sym :format-symbol) + (:import-from :std/list :ensure-car) + (:export :+default-element-type+ + :array-index :array-length + :negative-integer :non-negative-integer :positive-integer)) + +(defpkg :std/num + (:use :cl) + (:export ;; num/parse :parse-number :parse-real-number @@ -48,7 +140,12 @@ :encode-float32 :decode-float32 :encode-float64 - :decode-float64 + :decode-float64)) + +(defpkg :std/stream + (:use :cl) + (:import-from :std/type :non-negative-integer :positive-integer) + (:export ;; stream :copy-stream :wrapped-stream @@ -58,66 +155,53 @@ :prefixed-character-output-stream :stream-of :char-count-of :line-count-of :col-count-of :prev-col-count-of :col-index-of :write-prefix - :prefix-of - ;; path - #:wild-pathname - #:non-wild-pathname - #:absolute-pathname - #:relative-pathname - #:directory-pathname - #:absolute-directory-pathname - ;; file - #:file-pathname - #:with-open-files - #:write-stream-into-file - #:write-file-into-stream - #:file= - #:file-size - :file-size-in-octets - :+pathsep+ - :octet-vector= - :file-date - :file-timestamp - :directory-path-p - :hidden-path-p - :directory-path :find-files - :count-file-lines - ;; string - :*omit-nulls* - :*whitespaces* - :string-designator - :split - :trim - :collapse-whitespaces - :make-template-parser - :string-case - ;; fmt - :printer-status :fmt-row :format-sxhash :iprintln :fmt-tree :println - ;; sym - :ensure-symbol - :format-symbol - :make-keyword - :make-slot-name - :make-gensym - :make-gensym-list - :with-gensyms - :with-unique-names - :symbolicate - ;; list - :ensure-car - :ensure-cons - :appendf - :nconcf - :unionf - :nunionf - :reversef - :nreversef - :deletef - :let-binding-transform - :ensure-list :recons :memq :assq - :circular-list :circular-list-p :circular-tree-p - ;; :proper-list-of-length-p :proper-list-p :singleton-p - ;; thread + :prefix-of)) + +(defpkg :std/fu + (:use :cl) + (:export + :ensure-function + :ensure-functionf + :disjoin + :conjoin + :compose + :multiple-value-compose + :curry + :rcurry)) + +(defpkg :std/array + (:use :cl) + (:export :copy-array :signed-array-length)) + +(defpkg :std/hash-table + (:use :cl) + (:nicknames :std/ht) + (:export :hash-table-alist + :maphash-keys :hash-table-keys + :maphash-values :hash-table-values)) + +(defpkg :std/alien + (:use :cl :sb-alien) + (:import-from :std/sym :symbolicate) + (:export + :shared-object-name + :define-alien-loader + :c-string-to-string-list + :list-all-shared-objects + :num-cpus + :*cpus* + :loff-t + :memset)) + +(defpkg :std/mop + (:use :cl) + (:export :list-slot-values-using-class + :list-class-methods :list-class-slots :list-indirect-slot-methods)) + +(defpkg :std/thread + (:use :cl :sb-thread :sb-concurrency) + (:import-from :std/list :flatten) + (:export :print-thread-message-top-level :thread-support-p :find-thread-by-id :thread-id-list :make-threads :with-threads :finish-threads @@ -135,53 +219,15 @@ :job-tasks :make-job :job-p :task-object :make-task :task-p :task :wait-for-threads :task-pool-oracle :task-pool-jobs :task-pool-stages - :task-pool-workers :task-pool-results - ;; util - :find-package* #:find-symbol* #:symbol-call - :intern* #:export* #:import* #:shadowing-import* - :shadow* #:make-symbol* #:unintern* - :symbol-shadowing-p #:home-package-p - :symbol-package-name #:standard-common-lisp-symbol-p - :reify-package #:unreify-package #:reify-symbol #:unreify-symbol - :nuke-symbol-in-package #:nuke-symbol #:rehome-symbol - :ensure-package-unused #:delete-package* - :package-names #:packages-from-names #:fresh-package-name - :rename-package-away #:package-definition-form #:parse-defpkg-form - :ensure-package :defpkg - :save-lisp-tree-shake-and-die - :save-lisp-and-live - ;; ana - :awhen - :acond - :alambda - :nlet-tail - :alet% - :alet - :acond2 - :it - :aif - :this - :self - ;; pan - :pandoriclet - :pandoriclet-get - :pandoriclet-set - :get-pandoric - :with-pandoric - :pandoric-hotpatch - :pandoric-recode - :plambda - :pandoric-eval - ;; fu - :copy-array - :hash-table-alist - :until - :mkstr - :symb - :group - :flatten - :fact - :choose + :task-pool-workers :task-pool-results)) + +(defpkg :std/macs + (:use :cl) + (:import-from :std/sym :symb :mkstr :make-gensym-list :once-only) + (:import-from :std/named-readtables :in-readtable :parse-body) + (:import-from :std/list :flatten) + (:export + :named-lambda :g!-symbol-p :defmacro/g! :o!-symbol-p @@ -189,6 +235,9 @@ :defmacro! :defun! :dlambda + :until + :fact + :choose :make-tlist :tlist-left :tlist-right @@ -214,38 +263,32 @@ :define-constant :def! :eval-always - :merge! :sort! - :list-slot-values-using-class :list-class-methods :list-class-slots :list-indirect-slot-methods - :signed-array-length - :take - :maphash-keys - :hash-table-keys - :maphash-values - :hash-table-values - :current-lisp-implementation - :tmpfile - :ensure-function - :ensure-functionf - :disjoin - :conjoin - :compose - :multiple-value-compose - :curry - :rcurry - :named-lambda - ;; alien - :shared-object-name - :define-alien-loader - :c-string-to-string-list - :list-all-shared-objects - :num-cpus - :*cpus* - :loff-t - :memset - ;; os - :list-all-users - :list-all-groups - ;; bits + ;; ana + :awhen + :acond + :alambda + :nlet-tail + :alet% + :alet + :acond2 + :it + :aif + :this + :self + ;; pan + :pandoriclet + :pandoriclet-get + :pandoriclet-set + :get-pandoric + :with-pandoric + :pandoric-hotpatch + :pandoric-recode + :plambda + :pandoric-eval)) + +(defpkg :std/bit + (:use :cl) + (:export :make-bits :sign-bit :different-signs-p @@ -262,7 +305,9 @@ :clone-strings :clone-octets-to-alien :clone-octets-from-alien - :foreign-int-to-integer :foreign-int-to-bool :bool-to-foreign-int + :foreign-int-to-integer + :foreign-int-to-bool + :bool-to-foreign-int :bitfield :bitfield-slot-name :bitfield-slot-start @@ -283,7 +328,81 @@ :octet-vector-to-hex-string :octets-to-integer :integer-to-octets - :hexchar-to-int + :hexchar-to-int)) + +(defpkg :std/fmt + (:use :cl) + (:import-from :std/list :group :ensure-cons) + (:shadowing-import-from :uiop :println) + (:export :printer-status :fmt-row :format-sxhash :iprintln :fmt-tree :println)) + +(defpkg :std/path + (:use :cl) + (:export + :wild-pathname + :non-wild-pathname + :absolute-pathname + :relative-pathname + :directory-pathname + :absolute-directory-pathname)) + +(defpkg :std/os + (:use :cl) + (:export + :list-all-users + :list-all-groups)) + +(defpkg :std/file + (:use :cl) + (:export + :tmpfile + :file-pathname + :with-open-files + :write-stream-into-file + :write-file-into-stream + :file= + :file-size + :file-size-in-octets + :+pathsep+ + :octet-vector= + :file-date + :file-timestamp + :directory-path-p + :hidden-path-p + :directory-path + :find-files + :count-file-lines)) + +(defpkg :std/string + (:use :cl) + (:export + :*omit-nulls* + :*whitespaces* + :string-designator + :ssplit + :trim + :collapse-whitespaces + :make-template-parser + :string-case)) + +(defpkg :std/seq + (:use :cl) + (:import-from :std/array :signed-array-length) + (:export :take)) + +(defpkg :std/sys + (:use :cl) + (:export + :current-lisp-implementation + :save-lisp-tree-shake-and-die + :save-lisp-and-live)) + +(defpkg :std/readtable + (:use :cl) + (:import-from :std/named-readtables :defreadtable) + (:import-from :std/sym :symb) + (:import-from :std/macs :defmacro!) + (:export ;; readtable :|#"-reader| :|#`-reader| @@ -295,5 +414,8 @@ :|#~-reader| :_)) -(defpackage :std-user - (:use :cl :cl-user :std)) +(defpkg :std + (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien :sb-gray :sb-concurrency) + (:use-reexport :std/named-readtables :std/defpkg :std/err :std/sym :std/list :std/type :std/num + :std/stream :std/fu :std/array :std/hash-table :std/alien :std/mop :std/thread + :std/macs :std/bit :std/fmt :std/path :std/os :std/file :std/string :std/seq :std/sys :std/readtable)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/readtable.lisp --- a/lisp/std/readtable.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/readtable.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -6,7 +6,7 @@ ;;; Usage: (in-readtable :std) ;;; Code: -(in-package :std) +(in-package :std/readtable) (eval-when (:compile-toplevel :execute :load-toplevel) (defun |#`-reader| (stream sub-char numarg) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/seq.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/seq.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,24 @@ +;;; std/seq.lisp --- Standard Sequences + +;; + +;;; Code: +(in-package :std/seq) + +(defun take (n seq) + "Return, at most, the first N elements of SEQ, as a *new* sequence +of the same type as SEQ. + +If N is longer than SEQ, SEQ is simply copied. + +If N is negative, then |N| elements are taken (in their original +order) from the end of SEQ." + #+sbcl (declare (sb-ext:muffle-conditions style-warning)) + (declare (type signed-array-length n)) + (seq-dispatch seq + (if (minusp n) + (last seq (abs n)) + (firstn n seq)) + (if (minusp n) + (subseq seq (max 0 (+ (length seq) n))) + (subseq seq 0 (min n (length seq)))))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/std.asd --- a/lisp/std/std.asd Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/std.asd Mon Apr 22 23:14:47 2024 -0400 @@ -1,7 +1,7 @@ ;;; std.asd --- standard library (defsystem :std/named-readtables :version "0.1.0" - :components ((:file "named-readtables")) + :components ((:file "pkg") (:file "named-readtables")) :in-order-to ((test-op (test-op "std/tests")))) (register-system-packages "std/named-readtables" '(:std)) @@ -11,27 +11,38 @@ :depends-on (:std/named-readtables :cl-ppcre :sb-concurrency) :serial t :components ((:file "pkg") + (:file "defpkg") (:file "err") - (:file "bits") - (:module "num" - :components ((:file "float") - (:file "parse"))) - (:file "string") - (:file "fmt") (:file "sym") (:file "list") - (:file "util") - (:file "readtable") - (:file "ana") - (:file "pan") - (:file "fu") - (:file "types") + (:file "type") + (:module "num" + :components + ((:file "float") + (:file "parse"))) + (:file "stream") + (:module "fu" + :components + ((:file "curry"))) + (:file "array") + (:file "hash-table") + (:file "alien") + (:file "mop") + (:file "thread") + (:module "macs" + :components + ((:file "ana") + (:file "pan") + (:file "const"))) + (:file "bit") + (:file "fmt") (:file "path") - (:file "stream") + (:file "os") (:file "file") - (:file "thread") - (:file "defpkg") - (:file "alien")) + (:file "string") + (:file "seq") + (:file "sys") + (:file "readtable")) :in-order-to ((test-op (test-op "std/tests")))) (register-system-packages "std" '(:std)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/stream.lisp --- a/lisp/std/stream.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/stream.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,7 @@ ;; ;;; Code: -(in-package :std) +(in-package :std/stream) (defun copy-stream (input output &key (element-type (stream-element-type input)) (buffer-size 4096) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/string.lisp --- a/lisp/std/string.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/string.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -13,7 +13,7 @@ ;; decimal-value digit-value ;; unicode< unicode> unicode= unicode-equal ;; unicode<= unicode>=)) -(in-package :std) +(in-package :std/string) ;; (mapc (lambda (s) (export s)) sb-unicode-syms) ;; (reexport-from diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/sym.lisp --- a/lisp/std/sym.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/sym.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -3,7 +3,7 @@ ;; inspired by alexandria/symbols.lisp ;;; Code: -(in-package :std) +(in-package :std/sym) ;;(std::reexport-from ;; :sb-int @@ -12,7 +12,8 @@ ;; On SBCL, `with-unique-names' is defined under ;; src/code/primordial-extensions.lisp. We use that instead of ;; defining our own. -(setf (macro-function 'with-gensyms) (macro-function 'with-unique-names)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-gensyms) (macro-function 'with-unique-names))) (declaim (inline ensure-symbol)) (defun ensure-symbol (name &optional (package *package*)) @@ -69,26 +70,6 @@ (defun symb (&rest args) (values (intern (apply #'mkstr args)))) -(defun g!-symbol-p (s) - (and (symbolp s) - (> (length (symbol-name s)) 2) - (string= (symbol-name s) - "G!" - :start1 0 - :end1 2))) - -(defun o!-symbol-p (s) - (and (symbolp s) - (> (length (symbol-name s)) 2) - (string= (symbol-name s) - "O!" - :start1 0 - :end1 2))) - -(defun o!-symbol-to-g!-symbol (s) - (symb "G!" - (subseq (symbol-name s) 2))) - (sb-ext:with-unlocked-packages (:sb-int) (handler-bind ((sb-kernel:redefinition-warning #'muffle-warning)) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/sys.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/sys.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,56 @@ +;;; std/sys.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*- + +;; + +;;; Code: +(in-package :std/sys) + +;;; Introspection +;; (reexport-from :sb-introspect +;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit +;; :method-combination-lambda-list :deftype-lambda-list +;; :primitive-object-size :allocation-information +;; :function-type +;; :who-specializes-directly :who-specializes-generally +;; :find-function-callees :find-function-callers)) + +(defun current-lisp-implementation () + "Return the current lisp implemenation as a cons: (TYPE VERSION)" + (list + (lisp-implementation-type) + (lisp-implementation-version) + *features*)) + +;; TODO +(defun save-lisp-tree-shake-and-die (path &rest args) + "A naive tree-shaker for lisp." + (sb-ext:gc :full t) + (apply #'sb-ext:save-lisp-and-die path args)) + +(defun save-lisp-and-live (filename completion-function restart &rest args) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart))) + ;; fork it - assumes only one thread is running + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) ;; make simple-restart core + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (append + (list :toplevel #'restart-sbcl) + args))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/thread.lisp --- a/lisp/std/thread.lisp Sun Apr 21 22:38:49 2024 -0400 +++ b/lisp/std/thread.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -7,7 +7,7 @@ ;; mostly yoinked from sb-thread and friends ;;; Code: -(in-package :std) +(in-package :std/thread) ;; (sb-thread:thread-os-tid sb-thread:*current-thread*) ;; sb-thread:interrupt-thread @@ -203,26 +203,41 @@ (declare (ignore pool)) (make-threads count function :name *default-worker-name*))) -(defmacro define-task-kernel (name (&rest opts) &body body) - "Define a kernel function for tasks." - `(defun ,name (,@opts) +(defmacro define-task-kernel (name (&key args accessors) &body body) + "Define a task kernel. + +(define-task-kernel NAME (&key ARGS MAX MIN ACCESSORS) + +The kernel should process all options and return a function - the +'kernel function'. + +The kernel function is installed in worker threads by passing it to +SB-THREAD:MAKE-THREAD. It may accept a varying number of arguments +specified by ARGS. + +ACCESSORS is a list of pandoric accessors which can be called on the +kernel via an ORACLE. + +This interface is experimental and subject to change." + `(defun ,name (,@args) ,@body)) -(define-task-kernel default-task-kernel () +(define-task-kernel default-task-kernel (:args () ) "The default task kernel used to initialize the KERNEL slot of -task-pools. Currently, the kernel is used to initialize every worker -in the pool when it is spawned starts running immediately." +task-pools. + +" nil) (defgeneric spawn-worker (pool) (:method ((pool null)) (declare (ignore pool)) - (make-thread *default-task-kernel*))) + (make-thread (default-task-kernel)))) (defgeneric spawn-workers (pool count) (:method ((pool null) (count fixnum)) (declare (ignore pool)) - (make-threads count *default-task-kernel* :name *default-worker-name*))) + (make-threads count (default-task-kernel) :name *default-worker-name*))) (defstruct task-pool (oracle-id nil :type (or null (unsigned-byte 32))) @@ -325,7 +340,7 @@ ;; TODO.. (defmethod run-job ((self task-pool) (job job)) - (log:trace! "running remote job...") + #+log (log:trace! "running remote job...") (push-job job self)) (defclass stage () diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/type.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/std/type.lisp Mon Apr 22 23:14:47 2024 -0400 @@ -0,0 +1,157 @@ +;;; std/types.lisp --- Standard Types + +;; + +;;; Code: +(in-package :std/type) + +(defconstant +default-element-type+ 'character) + +(deftype array-index (&optional (length (1- array-dimension-limit))) + "Type designator for an index into array of LENGTH: an integer between +0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than +ARRAY-DIMENSION-LIMIT." + `(integer 0 (,length))) + +(deftype array-length (&optional (length (1- array-dimension-limit))) + "Type designator for a dimension of an array of LENGTH: an integer between +0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than +ARRAY-DIMENSION-LIMIT." + `(integer 0 ,length)) + +;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/) +;; except the RATIO related definitions and ARRAY-INDEX. +(macrolet + ((frob (type &optional (base-type type)) + (let ((subtype-names (list)) + (predicate-names (list))) + (flet ((make-subtype-name (format-control) + (let ((result (format-symbol :std format-control + (symbol-name type)))) + (push result subtype-names) + result)) + (make-predicate-name (sybtype-name) + (let ((result (format-symbol :std '#:~A-p + (symbol-name sybtype-name)))) + (push result predicate-names) + result)) + (make-docstring (range-beg range-end range-type) + (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf")))) + (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A." + type + (if (equal range-beg ''*) inf (ensure-car range-beg)) + (if (equal range-end ''*) inf (ensure-car range-end)))))) + (let* ((negative-name (make-subtype-name '#:negative-~a)) + (non-positive-name (make-subtype-name '#:non-positive-~a)) + (non-negative-name (make-subtype-name '#:non-negative-~a)) + (positive-name (make-subtype-name '#:positive-~a)) + (negative-p-name (make-predicate-name negative-name)) + (non-positive-p-name (make-predicate-name non-positive-name)) + (non-negative-p-name (make-predicate-name non-negative-name)) + (positive-p-name (make-predicate-name positive-name)) + (negative-extremum) + (positive-extremum) + (below-zero) + (above-zero) + (zero)) + (setf (values negative-extremum below-zero + above-zero positive-extremum zero) + (ecase type + (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0)) + (integer (values ''* -1 1 ''* 0)) + (rational (values ''* '(0) '(0) ''* 0)) + (real (values ''* '(0) '(0) ''* 0)) + (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0)) + (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0)) + (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0)) + (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0)) + (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0)))) + `(progn + (deftype ,negative-name () + ,(make-docstring negative-extremum below-zero :negative) + `(,',base-type ,,negative-extremum ,',below-zero)) + + (deftype ,non-positive-name () + ,(make-docstring negative-extremum zero :negative) + `(,',base-type ,,negative-extremum ,',zero)) + + (deftype ,non-negative-name () + ,(make-docstring zero positive-extremum :positive) + `(,',base-type ,',zero ,,positive-extremum)) + + (deftype ,positive-name () + ,(make-docstring above-zero positive-extremum :positive) + `(,',base-type ,',above-zero ,,positive-extremum)) + + (declaim (inline ,@predicate-names)) + + (defun ,negative-p-name (n) + (and (typep n ',type) + (< n ,zero))) + + (defun ,non-positive-p-name (n) + (and (typep n ',type) + (<= n ,zero))) + + (defun ,non-negative-p-name (n) + (and (typep n ',type) + (<= ,zero n))) + + (defun ,positive-p-name (n) + (and (typep n ',type) + (< ,zero n))))))))) + (frob fixnum integer) + (frob integer) + (frob rational) + (frob real) + (frob float) + (frob short-float) + (frob single-float) + (frob double-float) + (frob long-float)) + +(defun of-type (type) + "Returns a function of one argument, which returns true when its argument is +of TYPE." + (lambda (thing) (typep thing type))) + +(define-compiler-macro of-type (&whole form type &environment env) + ;; This can yeild a big benefit, but no point inlining the function + ;; all over the place if TYPE is not constant. + (if (constantp type env) + (with-gensyms (thing) + `(lambda (,thing) + (typep ,thing ,type))) + form)) + +(declaim (inline type=)) +(defun type= (type1 type2) + "Returns a primary value of T if TYPE1 and TYPE2 are the same type, +and a secondary value that is true is the type equality could be reliably +determined: primary value of NIL and secondary value of T indicates that the +types are not equivalent." + (multiple-value-bind (sub ok) (subtypep type1 type2) + (cond ((and ok sub) ; type1 is known to be a subtype of type 2 + ; so type= return values come from the second invocation of subtypep + (subtypep type2 type1)) + ;; type1 is assuredly NOT a subtype of type2, + ;; so assuredly type1 and type2 cannot be type= + (ok + (values nil t)) + ;; our first result is uncertain ( ok == nil ) and it follows + ;; from specification of SUBTYPEP that sub = ok = NIL + (t + (assert (not sub)) ; is the implementation correct? + (multiple-value-bind (sub2 ok2) + (subtypep type2 type1) + (if (and (not sub2) ok2) ; we KNOW type2 is not a subtype of type1 + ;; so our results are certain... + (values nil t) + ;; otherwise, either type2 is surely a subtype of type1 (t t) + ;; or type2 is not a subtype of type1, but we don't + ;; know that for sure (nil nil) + ;; In either case our result is negative but unsure + (values nil nil))))))) + +(define-modify-macro coercef (type-spec) coerce + "Modify-macro for COERCE.") diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/types.lisp --- a/lisp/std/types.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,157 +0,0 @@ -;;; std/types.lisp --- Standard Types - -;; - -;;; Code: -(in-package :std) - -(defconstant +default-element-type+ 'character) - -(deftype array-index (&optional (length (1- array-dimension-limit))) - "Type designator for an index into array of LENGTH: an integer between -0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than -ARRAY-DIMENSION-LIMIT." - `(integer 0 (,length))) - -(deftype array-length (&optional (length (1- array-dimension-limit))) - "Type designator for a dimension of an array of LENGTH: an integer between -0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than -ARRAY-DIMENSION-LIMIT." - `(integer 0 ,length)) - -;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/) -;; except the RATIO related definitions and ARRAY-INDEX. -(macrolet - ((frob (type &optional (base-type type)) - (let ((subtype-names (list)) - (predicate-names (list))) - (flet ((make-subtype-name (format-control) - (let ((result (format-symbol :std format-control - (symbol-name type)))) - (push result subtype-names) - result)) - (make-predicate-name (sybtype-name) - (let ((result (format-symbol :std '#:~A-p - (symbol-name sybtype-name)))) - (push result predicate-names) - result)) - (make-docstring (range-beg range-end range-type) - (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf")))) - (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A." - type - (if (equal range-beg ''*) inf (ensure-car range-beg)) - (if (equal range-end ''*) inf (ensure-car range-end)))))) - (let* ((negative-name (make-subtype-name '#:negative-~a)) - (non-positive-name (make-subtype-name '#:non-positive-~a)) - (non-negative-name (make-subtype-name '#:non-negative-~a)) - (positive-name (make-subtype-name '#:positive-~a)) - (negative-p-name (make-predicate-name negative-name)) - (non-positive-p-name (make-predicate-name non-positive-name)) - (non-negative-p-name (make-predicate-name non-negative-name)) - (positive-p-name (make-predicate-name positive-name)) - (negative-extremum) - (positive-extremum) - (below-zero) - (above-zero) - (zero)) - (setf (values negative-extremum below-zero - above-zero positive-extremum zero) - (ecase type - (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0)) - (integer (values ''* -1 1 ''* 0)) - (rational (values ''* '(0) '(0) ''* 0)) - (real (values ''* '(0) '(0) ''* 0)) - (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0)) - (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0)) - (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0)) - (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0)) - (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0)))) - `(progn - (deftype ,negative-name () - ,(make-docstring negative-extremum below-zero :negative) - `(,',base-type ,,negative-extremum ,',below-zero)) - - (deftype ,non-positive-name () - ,(make-docstring negative-extremum zero :negative) - `(,',base-type ,,negative-extremum ,',zero)) - - (deftype ,non-negative-name () - ,(make-docstring zero positive-extremum :positive) - `(,',base-type ,',zero ,,positive-extremum)) - - (deftype ,positive-name () - ,(make-docstring above-zero positive-extremum :positive) - `(,',base-type ,',above-zero ,,positive-extremum)) - - (declaim (inline ,@predicate-names)) - - (defun ,negative-p-name (n) - (and (typep n ',type) - (< n ,zero))) - - (defun ,non-positive-p-name (n) - (and (typep n ',type) - (<= n ,zero))) - - (defun ,non-negative-p-name (n) - (and (typep n ',type) - (<= ,zero n))) - - (defun ,positive-p-name (n) - (and (typep n ',type) - (< ,zero n))))))))) - (frob fixnum integer) - (frob integer) - (frob rational) - (frob real) - (frob float) - (frob short-float) - (frob single-float) - (frob double-float) - (frob long-float)) - -(defun of-type (type) - "Returns a function of one argument, which returns true when its argument is -of TYPE." - (lambda (thing) (typep thing type))) - -(define-compiler-macro of-type (&whole form type &environment env) - ;; This can yeild a big benefit, but no point inlining the function - ;; all over the place if TYPE is not constant. - (if (constantp type env) - (with-gensyms (thing) - `(lambda (,thing) - (typep ,thing ,type))) - form)) - -(declaim (inline type=)) -(defun type= (type1 type2) - "Returns a primary value of T if TYPE1 and TYPE2 are the same type, -and a secondary value that is true is the type equality could be reliably -determined: primary value of NIL and secondary value of T indicates that the -types are not equivalent." - (multiple-value-bind (sub ok) (subtypep type1 type2) - (cond ((and ok sub) ; type1 is known to be a subtype of type 2 - ; so type= return values come from the second invocation of subtypep - (subtypep type2 type1)) - ;; type1 is assuredly NOT a subtype of type2, - ;; so assuredly type1 and type2 cannot be type= - (ok - (values nil t)) - ;; our first result is uncertain ( ok == nil ) and it follows - ;; from specification of SUBTYPEP that sub = ok = NIL - (t - (assert (not sub)) ; is the implementation correct? - (multiple-value-bind (sub2 ok2) - (subtypep type2 type1) - (if (and (not sub2) ok2) ; we KNOW type2 is not a subtype of type1 - ;; so our results are certain... - (values nil t) - ;; otherwise, either type2 is surely a subtype of type1 (t t) - ;; or type2 is not a subtype of type1, but we don't - ;; know that for sure (nil nil) - ;; In either case our result is negative but unsure - (values nil nil))))))) - -(define-modify-macro coercef (type-spec) coerce - "Modify-macro for COERCE.") diff -r 14b0ee8d09c1 -r a0dfde3cb3c4 lisp/std/util.lisp --- a/lisp/std/util.lisp Sun Apr 21 22:38:49 2024 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -;;; std/util.lisp @ 2023-10-14.03:28:40 -*- mode: lisp; -*- -;;; Code: -(in-package :std) - -;;; Misc -(defmacro until (condition &body body) - (let ((block-name (gensym))) - `(block ,block-name - (loop - (if ,condition - (return-from ,block-name nil) - (progn ,@body)))))) - -(defmacro defmacro/g! (name args &rest body) - (let ((syms (remove-duplicates - (remove-if-not #'g!-symbol-p - (flatten body))))) - (multiple-value-bind (body declarations docstring) - (parse-body body :documentation t) - `(defmacro ,name ,args - ,@(when docstring - (list docstring)) - ,@declarations - (let ,(mapcar - (lambda (s) - `(,s (gensym ,(subseq - (symbol-name s) - 2)))) - syms) - ,@body))))) - -(defmacro defmacro! (name args &rest body) - (let* ((os (remove-if-not #'o!-symbol-p (flatten args))) - (gs (mapcar #'o!-symbol-to-g!-symbol os))) - (multiple-value-bind (body declarations docstring) - (parse-body body :documentation t) - `(defmacro/g! ,name ,args - ,@(when docstring - (list docstring)) - ,@declarations - `(let ,(mapcar #'list (list ,@gs) (list ,@os)) - ,(progn ,@body)))))) - -(defmacro defun! (name args &body body) - (let ((syms (remove-duplicates - (remove-if-not #'g!-symbol-p - (flatten body))))) - (multiple-value-bind (body declarations docstring) - (parse-body body :documentation t) - `(defun ,name ,args - ,@(when docstring - (list docstring)) - ,@declarations - (let ,(mapcar (lambda (s) - `(,s (gensym ,(subseq (symbol-name s) - 2)))) - syms) - ,@body))))) - -(defmacro! dlambda (&rest ds) - "Dynamic dispatch lambda." - `(lambda (&rest ,g!args) - (case (car ,g!args) - ,@(mapcar - (lambda (d) - `(,(if (eq t (car d)) - t - (list (car d))) - (apply (lambda ,@(cdr d)) - ,(if (eq t (car d)) - g!args - `(cdr ,g!args))))) - ds)))) - -;; LoL tlist -;; (declaim (inline make-tlist tlist-left -;; tlist-right tlist-empty-p)) - -;; (defun make-tlist () (cons nil nil)) -;; (defun tlist-left (tl) (caar tl)) -;; (defun tlist-right (tl) (cadr tl)) -;; (defun tlist-empty-p (tl) (null (car tl))) - -;; (declaim (inline tlist-add-left -;; tlist-add-right)) - -;; (defun tlist-add-left (tl it) -;; (let ((x (cons it (car tl)))) -;; (if (tlist-empty-p tl) -;; (setf (cdr tl) x)) -;; (setf (car tl) x))) - -;; (defun tlist-add-right (tl it) -;; (let ((x (cons it nil))) -;; (if (tlist-empty-p tl) -;; (setf (car tl) x) -;; (setf (cddr tl) x)) -;; (setf (cdr tl) x))) - -;; (declaim (inline tlist-rem-left)) - -;; (defun tlist-rem-left (tl) -;; (if (tlist-empty-p tl) -;; (error "Remove from empty tlist") -;; (let ((x (car tl))) -;; (setf (car tl) (cdar tl)) -;; (if (tlist-empty-p tl) -;; (setf (cdr tl) nil)) ;; For gc -;; (car x)))) - -;; (declaim (inline tlist-update)) - -;; (defun tlist-update (tl) -;; (setf (cdr tl) (last (car tl)))) - -(defun build-batcher-sn (n) - (let* (network - (tee (ceiling (log n 2))) - (p (ash 1 (- tee 1)))) - (loop while (> p 0) do - (let ((q (ash 1 (- tee 1))) - (r 0) - (d p)) - (loop while (> d 0) do - (loop for i from 0 to (- n d 1) do - (if (= (logand i p) r) - (push (list i (+ i d)) - network))) - (setf d (- q p) - q (ash q -1) - r p))) - (setf p (ash p -1))) - (nreverse network))) - -;; TODO -(defun save-lisp-tree-shake-and-die (path &rest args) - "A naive tree-shaker for lisp." - (sb-ext:gc :full t) - (apply #'sb-ext:save-lisp-and-die path args)) - -(defun save-lisp-and-live (filename completion-function restart &rest args) - (flet ((restart-sbcl () - (sb-debug::enable-debugger) - (setf sb-impl::*descriptor-handlers* nil) - (funcall restart))) - ;; fork it - assumes only one thread is running - (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) ;; make simple-restart core - (sb-posix:close pipe-in) - (sb-debug::disable-debugger) - (apply #'sb-ext:save-lisp-and-die filename - (append - (list :toplevel #'restart-sbcl) - args))) - (t - (sb-posix:close pipe-out) - (sb-sys:add-fd-handler - pipe-in :input - (lambda (fd) - (sb-sys:invalidate-descriptor fd) - (sb-posix:close fd) - (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) ;; wait for master - (assert (= pid rpid)) - (assert (sb-posix:wifexited status)) - (funcall completion-function - (zerop (sb-posix:wexitstatus status))))))))))))