1.1--- a/emacs/lib/publish.el Sat Jul 27 00:40:29 2024 -0400
1.2+++ b/emacs/lib/publish.el Sun Jul 28 20:49:47 2024 -0400
1.3@@ -8,7 +8,7 @@
1.4 ;; vendored
1.5 (require 'htmlize)
1.6 (defvar project-dir "~/comp/org")
1.7-(defvar publish-dir "/mnt/y/stash/compiler.company")
1.8+(defvar publish-dir "/tmp/www")
1.9 (defvar html-theme nil)
1.10 (defvar url "https://compiler.company")
1.11 (defvar vc-url "https://vc.compiler.company")
2.1--- a/lisp/bin/skel.lisp Sat Jul 27 00:40:29 2024 -0400
2.2+++ b/lisp/bin/skel.lisp Sun Jul 28 20:49:47 2024 -0400
2.3@@ -32,7 +32,8 @@
2.4
2.5 (defcmd skc-init
2.6 (let ((file (when *args* (pop *args*)))
2.7- (name (when (> *argc* 1) (pop *args*)))) ;; TODO: test, may need to be
2.8+ (name (when (> *argc* 1) (pop *args*))))
2.9+ ;; TODO: test, may need to be
2.10 ;; sequential for side-effect
2.11 ;; of pop
2.12 (handler-bind
3.1--- a/lisp/lib/cli/clap/macs.lisp Sat Jul 27 00:40:29 2024 -0400
3.2+++ b/lisp/lib/cli/clap/macs.lisp Sun Jul 28 20:49:47 2024 -0400
3.3@@ -32,7 +32,8 @@
3.4 ;; TODO fix these macros
3.5 (defmacro defcmd (name &body body)
3.6 `(defun ,name (args opts)
3.7- (declare (ignorable args opts))
3.8+ (declare (ignorable args opts)
3.9+ (list args opts))
3.10 (setq
3.11 *argc* (length args)
3.12 *optc* (length opts)
3.13@@ -42,7 +43,7 @@
3.14
3.15 (defmacro defopt (name &body body)
3.16 `(defun ,name (&optional arg)
3.17- (declare (ignorable arg))
3.18+ (declare (ignorable arg) (list arg))
3.19 (setq *arg* arg)
3.20 ,@body))
3.21
4.1--- a/lisp/lib/cli/clap/opt.lisp Sat Jul 27 00:40:29 2024 -0400
4.2+++ b/lisp/lib/cli/clap/opt.lisp Sun Jul 28 20:49:47 2024 -0400
4.3@@ -6,7 +6,6 @@
4.4 (in-package :cli/clap/obj)
4.5
4.6 ;;; Parsers
4.7-;; TODO 2024-03-16: this should map directly to Lisp types (fixnum, boolean, etc)
4.8 (make-opt-parser string $val)
4.9
4.10 (make-opt-parser boolean (when $val t))
5.1--- a/lisp/lib/cli/clap/vars.lisp Sat Jul 27 00:40:29 2024 -0400
5.2+++ b/lisp/lib/cli/clap/vars.lisp Sun Jul 28 20:49:47 2024 -0400
5.3@@ -36,7 +36,7 @@
5.4 "Current command options.
5.5 Bound for the lifetime of a DEFOPT function.")
5.6
5.7-(declaim (integer *argc* *optc*))
5.8+(declaim (unsigned-byte *argc* *optc*))
5.9 (defvar *argc* 0
5.10 "Current count of command arguments.
5.11 This value may be updated throughout the lifetime of a function defined with
6.1--- a/lisp/lib/io/pkg.lisp Sat Jul 27 00:40:29 2024 -0400
6.2+++ b/lisp/lib/io/pkg.lisp Sun Jul 28 20:49:47 2024 -0400
6.3@@ -13,7 +13,7 @@
6.4
6.5 ;;; Code:
6.6 (defpackage :io/proto
6.7- (:use :cl :std/err)
6.8+ (:use :cl :std/condition)
6.9 (:export :io-error))
6.10
6.11 (defpackage :io/ring
7.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2+++ b/lisp/std/condition.lisp Sun Jul 28 20:49:47 2024 -0400
7.3@@ -0,0 +1,193 @@
7.4+;;; condition.lisp --- Conditions and other exception handlers
7.5+
7.6+;;; Code:
7.7+(in-package :std/condition)
7.8+
7.9+(defvar *std-error-message* "An error occured")
7.10+
7.11+(define-condition std-error (error)
7.12+ ((message :initarg :message
7.13+ :initform *std-error-message*
7.14+ :reader std-error-message))
7.15+ (:documentation "Std Error")
7.16+ (:report (lambda (condition stream)
7.17+ (format stream "~X" (std-error-message condition)))))
7.18+
7.19+(defun std-error (&rest args)
7.20+ (cerror
7.21+ "Ignore and continue"
7.22+ 'std-error
7.23+ :message (format nil "~A: ~A" *std-error-message* args)))
7.24+
7.25+(defun car-eql (a cons)
7.26+ (eql a (car cons)))
7.27+
7.28+(defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options)
7.29+ "Define an error condition."
7.30+ (let ((fun (member :auto options :test #'car-eql)))
7.31+ (when fun (setq options (remove (car fun) options)))
7.32+ `(prog1
7.33+ (define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options)
7.34+ (when ',fun (def-error-reporter ,name)))))
7.35+
7.36+(defmacro def-error-reporter (err)
7.37+ `(defun ,err (&rest args)
7.38+ ,(format nil "Signal an error of type ~A with ARGS." err)
7.39+ (cerror
7.40+ "Ignore and continue"
7.41+ ',err
7.42+ :message (format nil "~A: ~A" *std-error-message* args))))
7.43+
7.44+(defmacro nyi! (&optional comment)
7.45+ `(prog1
7.46+ (error "Not Yet Implemented!")
7.47+ (when ',comment (print ',comment))))
7.48+
7.49+(defun required-argument (&optional name)
7.50+ "Signals an error for a missing argument of NAME. Intended for
7.51+use as an initialization form for structure and class-slots, and
7.52+a default value for required keyword arguments."
7.53+ (error "Required argument ~@[~S ~]missing." name))
7.54+
7.55+(define-condition simple-style-warning (simple-warning style-warning)
7.56+ ())
7.57+
7.58+(defun simple-style-warning (message &rest args)
7.59+ (warn 'simple-style-warning :format-control message :format-arguments args))
7.60+
7.61+;; We don't specify a :report for simple-reader-error to let the
7.62+;; underlying implementation report the line and column position for
7.63+;; us. Unfortunately this way the message from simple-error is not
7.64+;; displayed, unless there's special support for that in the
7.65+;; implementation. But even then it's still inspectable from the
7.66+;; debugger...
7.67+(define-condition simple-reader-error
7.68+ (sb-int:simple-reader-error)
7.69+ ())
7.70+
7.71+(defun simple-reader-error (stream message &rest args)
7.72+ (error 'simple-reader-error
7.73+ :stream stream
7.74+ :format-control message
7.75+ :format-arguments args))
7.76+
7.77+(define-condition simple-parse-error (simple-error parse-error)
7.78+ ())
7.79+
7.80+(defun simple-parse-error (message &rest args)
7.81+ (error 'simple-parse-error
7.82+ :format-control message
7.83+ :format-arguments args))
7.84+
7.85+(define-condition simple-program-error (simple-error program-error)
7.86+ ())
7.87+
7.88+(defun simple-program-error (message &rest args)
7.89+ (error 'simple-program-error
7.90+ :format-control message
7.91+ :format-arguments args))
7.92+
7.93+(define-condition circular-dependency (simple-error)
7.94+ ((items
7.95+ :initarg :items
7.96+ :initform (error "Must specify items")
7.97+ :reader circular-dependency-items))
7.98+ (:report (lambda (condition stream)
7.99+ (declare (ignore condition))
7.100+ (format stream "Circular dependency detected")))
7.101+ (:documentation "A condition which is signalled when a circular dependency is encountered."))
7.102+
7.103+(define-condition unknown-argument (error)
7.104+ ((name
7.105+ :initarg :name
7.106+ :initform (error "Must specify argument name")
7.107+ :reader unknown-argument-name)
7.108+ (kind
7.109+ :initarg :kind
7.110+ :initform (error "Must specify argument kind")
7.111+ :reader unknown-argument-kind))
7.112+ (:report (lambda (condition stream)
7.113+ (format stream "Unknown argument ~A of kind ~A"
7.114+ (unknown-argument-name condition)
7.115+ (unknown-argument-kind condition))))
7.116+ (:documentation "A condition which is signalled when an unknown argument is encountered."))
7.117+
7.118+(defun unknown-argument-p (value)
7.119+ (typep value 'unknown-argument))
7.120+
7.121+(define-condition missing-argument (simple-error)
7.122+ ((item
7.123+ :initarg :item
7.124+ :initform (error "Must specify argument item")
7.125+ :reader missing-argument-item)
7.126+ (command
7.127+ :initarg :command
7.128+ :initform (error "Must specify command")
7.129+ :reader missing-argument-command))
7.130+ (:report (lambda (condition stream)
7.131+ (declare (ignore condition))
7.132+ (format stream "Missing argument")))
7.133+ (:documentation "A condition which is signalled when an option expects an argument, but none was provided"))
7.134+
7.135+(defun missing-argument-p (value)
7.136+ (typep value 'missing-argument))
7.137+
7.138+(define-condition invalid-argument (simple-error)
7.139+ ((item
7.140+ :initarg :item
7.141+ :initform (error "Must specify argument item")
7.142+ :reader invalid-argument-item
7.143+ :documentation "The argument which is identified as invalid")
7.144+ (reason
7.145+ :initarg :reason
7.146+ :initform (error "Must specify reason")
7.147+ :reader invalid-argument-reason
7.148+ :documentation "The reason why this argument is invalid"))
7.149+ (:report (lambda (condition stream)
7.150+ (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition))))
7.151+ (:documentation "A condition which is signalled when an argument is identified as invalid."))
7.152+
7.153+(defmacro ignore-some-conditions ((&rest conditions) &body body)
7.154+ "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
7.155+list determines which specific conditions are to be ignored."
7.156+ `(handler-case
7.157+ (progn ,@body)
7.158+ ,@(loop for condition in conditions collect
7.159+ `(,condition (c) (values nil c)))))
7.160+
7.161+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
7.162+ "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
7.163+the cleanup CLAUSES are run.
7.164+
7.165+ clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
7.166+
7.167+Clauses can be given in any order, and more than one clause can be
7.168+given for each circumstance. The clauses whose denoted circumstance
7.169+occured, are executed in the order the clauses appear.
7.170+
7.171+ABORT-FLAG is the name of a variable that will be bound to T in
7.172+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
7.173+otherwise.
7.174+
7.175+Examples:
7.176+
7.177+ (unwind-protect-case ()
7.178+ (protected-form)
7.179+ (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
7.180+ (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
7.181+ (:always (format t \"This is evaluated in either case.~%\")))
7.182+
7.183+ (unwind-protect-case (aborted-p)
7.184+ (protected-form)
7.185+ (:always (perform-cleanup-if aborted-p)))
7.186+"
7.187+ (check-type abort-flag (or null symbol))
7.188+ (let ((gflag (gensym "FLAG+")))
7.189+ `(let ((,gflag t))
7.190+ (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
7.191+ (let ,(and abort-flag `((,abort-flag ,gflag)))
7.192+ ,@(loop for (cleanup-kind . forms) in clauses
7.193+ collect (ecase cleanup-kind
7.194+ (:normal `(when (not ,gflag) ,@forms))
7.195+ (:abort `(when ,gflag ,@forms))
7.196+ (:always `(progn ,@forms)))))))))
8.1--- a/lisp/std/err.lisp Sat Jul 27 00:40:29 2024 -0400
8.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3@@ -1,193 +0,0 @@
8.4-;;; err.lisp --- Conditions and other exception handlers
8.5-
8.6-;;; Code:
8.7-(in-package :std/err)
8.8-
8.9-(defvar *std-error-message* "An error occured")
8.10-
8.11-(define-condition std-error (error)
8.12- ((message :initarg :message
8.13- :initform *std-error-message*
8.14- :reader std-error-message))
8.15- (:documentation "Std Error")
8.16- (:report (lambda (condition stream)
8.17- (format stream "~X" (std-error-message condition)))))
8.18-
8.19-(defun std-error (&rest args)
8.20- (cerror
8.21- "Ignore and continue"
8.22- 'std-error
8.23- :message (format nil "~A: ~A" *std-error-message* args)))
8.24-
8.25-(defun car-eql (a cons)
8.26- (eql a (car cons)))
8.27-
8.28-(defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options)
8.29- "Define an error condition."
8.30- (let ((fun (member :auto options :test #'car-eql)))
8.31- (when fun (setq options (remove (car fun) options)))
8.32- `(prog1
8.33- (define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options)
8.34- (when ',fun (def-error-reporter ,name)))))
8.35-
8.36-(defmacro def-error-reporter (err)
8.37- `(defun ,err (&rest args)
8.38- ,(format nil "Signal an error of type ~A with ARGS." err)
8.39- (cerror
8.40- "Ignore and continue"
8.41- ',err
8.42- :message (format nil "~A: ~A" *std-error-message* args))))
8.43-
8.44-(defmacro nyi! (&optional comment)
8.45- `(prog1
8.46- (error "Not Yet Implemented!")
8.47- (when ',comment (print ',comment))))
8.48-
8.49-(defun required-argument (&optional name)
8.50- "Signals an error for a missing argument of NAME. Intended for
8.51-use as an initialization form for structure and class-slots, and
8.52-a default value for required keyword arguments."
8.53- (error "Required argument ~@[~S ~]missing." name))
8.54-
8.55-(define-condition simple-style-warning (simple-warning style-warning)
8.56- ())
8.57-
8.58-(defun simple-style-warning (message &rest args)
8.59- (warn 'simple-style-warning :format-control message :format-arguments args))
8.60-
8.61-;; We don't specify a :report for simple-reader-error to let the
8.62-;; underlying implementation report the line and column position for
8.63-;; us. Unfortunately this way the message from simple-error is not
8.64-;; displayed, unless there's special support for that in the
8.65-;; implementation. But even then it's still inspectable from the
8.66-;; debugger...
8.67-(define-condition simple-reader-error
8.68- (sb-int:simple-reader-error)
8.69- ())
8.70-
8.71-(defun simple-reader-error (stream message &rest args)
8.72- (error 'simple-reader-error
8.73- :stream stream
8.74- :format-control message
8.75- :format-arguments args))
8.76-
8.77-(define-condition simple-parse-error (simple-error parse-error)
8.78- ())
8.79-
8.80-(defun simple-parse-error (message &rest args)
8.81- (error 'simple-parse-error
8.82- :format-control message
8.83- :format-arguments args))
8.84-
8.85-(define-condition simple-program-error (simple-error program-error)
8.86- ())
8.87-
8.88-(defun simple-program-error (message &rest args)
8.89- (error 'simple-program-error
8.90- :format-control message
8.91- :format-arguments args))
8.92-
8.93-(define-condition circular-dependency (simple-error)
8.94- ((items
8.95- :initarg :items
8.96- :initform (error "Must specify items")
8.97- :reader circular-dependency-items))
8.98- (:report (lambda (condition stream)
8.99- (declare (ignore condition))
8.100- (format stream "Circular dependency detected")))
8.101- (:documentation "A condition which is signalled when a circular dependency is encountered."))
8.102-
8.103-(define-condition unknown-argument (error)
8.104- ((name
8.105- :initarg :name
8.106- :initform (error "Must specify argument name")
8.107- :reader unknown-argument-name)
8.108- (kind
8.109- :initarg :kind
8.110- :initform (error "Must specify argument kind")
8.111- :reader unknown-argument-kind))
8.112- (:report (lambda (condition stream)
8.113- (format stream "Unknown argument ~A of kind ~A"
8.114- (unknown-argument-name condition)
8.115- (unknown-argument-kind condition))))
8.116- (:documentation "A condition which is signalled when an unknown argument is encountered."))
8.117-
8.118-(defun unknown-argument-p (value)
8.119- (typep value 'unknown-argument))
8.120-
8.121-(define-condition missing-argument (simple-error)
8.122- ((item
8.123- :initarg :item
8.124- :initform (error "Must specify argument item")
8.125- :reader missing-argument-item)
8.126- (command
8.127- :initarg :command
8.128- :initform (error "Must specify command")
8.129- :reader missing-argument-command))
8.130- (:report (lambda (condition stream)
8.131- (declare (ignore condition))
8.132- (format stream "Missing argument")))
8.133- (:documentation "A condition which is signalled when an option expects an argument, but none was provided"))
8.134-
8.135-(defun missing-argument-p (value)
8.136- (typep value 'missing-argument))
8.137-
8.138-(define-condition invalid-argument (simple-error)
8.139- ((item
8.140- :initarg :item
8.141- :initform (error "Must specify argument item")
8.142- :reader invalid-argument-item
8.143- :documentation "The argument which is identified as invalid")
8.144- (reason
8.145- :initarg :reason
8.146- :initform (error "Must specify reason")
8.147- :reader invalid-argument-reason
8.148- :documentation "The reason why this argument is invalid"))
8.149- (:report (lambda (condition stream)
8.150- (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition))))
8.151- (:documentation "A condition which is signalled when an argument is identified as invalid."))
8.152-
8.153-(defmacro ignore-some-conditions ((&rest conditions) &body body)
8.154- "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
8.155-list determines which specific conditions are to be ignored."
8.156- `(handler-case
8.157- (progn ,@body)
8.158- ,@(loop for condition in conditions collect
8.159- `(,condition (c) (values nil c)))))
8.160-
8.161-(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
8.162- "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
8.163-the cleanup CLAUSES are run.
8.164-
8.165- clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
8.166-
8.167-Clauses can be given in any order, and more than one clause can be
8.168-given for each circumstance. The clauses whose denoted circumstance
8.169-occured, are executed in the order the clauses appear.
8.170-
8.171-ABORT-FLAG is the name of a variable that will be bound to T in
8.172-CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
8.173-otherwise.
8.174-
8.175-Examples:
8.176-
8.177- (unwind-protect-case ()
8.178- (protected-form)
8.179- (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
8.180- (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
8.181- (:always (format t \"This is evaluated in either case.~%\")))
8.182-
8.183- (unwind-protect-case (aborted-p)
8.184- (protected-form)
8.185- (:always (perform-cleanup-if aborted-p)))
8.186-"
8.187- (check-type abort-flag (or null symbol))
8.188- (let ((gflag (gensym "FLAG+")))
8.189- `(let ((,gflag t))
8.190- (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
8.191- (let ,(and abort-flag `((,abort-flag ,gflag)))
8.192- ,@(loop for (cleanup-kind . forms) in clauses
8.193- collect (ecase cleanup-kind
8.194- (:normal `(when (not ,gflag) ,@forms))
8.195- (:abort `(when ,gflag ,@forms))
8.196- (:always `(progn ,@forms)))))))))
9.1--- a/lisp/std/num/leb128.lisp Sat Jul 27 00:40:29 2024 -0400
9.2+++ b/lisp/std/num/leb128.lisp Sun Jul 28 20:49:47 2024 -0400
9.3@@ -88,7 +88,7 @@
9.4 (incf in))
9.5 ret))
9.6
9.7-(declaim (ftype (function ((vector unsigned-byte) &optional t) integer) decode-uleb128))
9.8+(declaim (ftype (function (vector &optional t) integer) decode-uleb128))
9.9 (defun decode-uleb128 (bits &optional (start 0))
9.10 "Decode an unsigned integer from ULEB128 byte array."
9.11 (let ((result 0) (shift 0) (curr) (counter 0))
10.1--- a/lisp/std/pkg.lisp Sat Jul 27 00:40:29 2024 -0400
10.2+++ b/lisp/std/pkg.lisp Sun Jul 28 20:49:47 2024 -0400
10.3@@ -9,7 +9,7 @@
10.4
10.5 (in-package :std-int)
10.6
10.7-(defpackage :std/err
10.8+(defpackage :std/condition
10.9 (:use :cl)
10.10 (:export ;; err
10.11 :std-error :std-error-message
10.12@@ -448,7 +448,7 @@
10.13
10.14 (defpkg :std
10.15 (:use :cl :sb-unicode :cl-ppcre :sb-mop :sb-c :sb-thread :sb-alien :sb-gray :sb-concurrency)
10.16- (:use-reexport :std/named-readtables :std/defpkg :std/err
10.17+ (:use-reexport :std/named-readtables :std/defpkg :std/condition
10.18 :std/sym :std/list :std/type :std/num
10.19 :std/stream :std/fu :std/array :std/hash-table
10.20 :std/alien :std/mop :std/thread :std/task
11.1--- a/lisp/std/std.asd Sat Jul 27 00:40:29 2024 -0400
11.2+++ b/lisp/std/std.asd Sun Jul 28 20:49:47 2024 -0400
11.3@@ -21,7 +21,7 @@
11.4 :serial t
11.5 :components ((:file "defpkg")
11.6 (:file "pkg")
11.7- (:file "err")
11.8+ (:file "condition")
11.9 (:file "sym")
11.10 (:file "list")
11.11 (:file "type")
11.12@@ -65,5 +65,9 @@
11.13 (defsystem :std/tests
11.14 :depends-on (:std :rt)
11.15 :serial t
11.16- :components ((:file "tests"))
11.17+ :components ((:module "tests"
11.18+ :components
11.19+ ((:file "pkg")
11.20+ (:file "num")
11.21+ (:file "task"))))
11.22 :perform (test-op (o c) (symbol-call :rt :do-tests :std)))
12.1--- a/lisp/std/tests.lisp Sat Jul 27 00:40:29 2024 -0400
12.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
12.3@@ -1,276 +0,0 @@
12.4-;;; tests.lisp --- std system tests
12.5-
12.6-;;; Commentary:
12.7-
12.8-;; TODO: fix false positives when using (eval-test)
12.9-
12.10-;;; Code:
12.11-(in-package :std-int)
12.12-(defpkg :std/tests
12.13- (:use :cl :std :rt :sb-thread :std/fu))
12.14-(in-package :std/tests)
12.15-(defsuite :std)
12.16-(in-suite :std)
12.17-(in-readtable :std)
12.18-;; prevent threadlocks
12.19-;; (setf sb-unix::*on-dangerous-wait* :error)
12.20-
12.21-;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
12.22-(deftest readtables (:skip nil)
12.23- "Test :std readtable"
12.24- (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
12.25- (is (string= #"test "foo" "# "test \"foo\" "))
12.26- ;; from curry-compose-reader-macros test suite
12.27- (is (equal (funcall {list 1} 2) '(1 2))) ;; curry.1
12.28- (is (equal (mapcar {+ 1} '(1 2 3 4)) '(2 3 4 5))) ;; curry.2
12.29- (is (equal (funcall {1 list 1} 2) '(1 2))) ;; curry.fixed-arity
12.30- (is (equal (funcall {2 list _ 2} 3 4) '(3 4 2))) ;; curry.fixed-arity.2
12.31- (signals error
12.32- (let ((f {1 list 1}))
12.33- (progn (funcall f) nil))) ;; curry.fixed-arity.1
12.34- (signals error
12.35- (locally (declare (optimize safety))
12.36- (let ((f {1 list 1}))
12.37- (progn (funcall f 'a 'b) nil)))) ;; curry.fixed-arity-error.2
12.38- (is (equal (funcall {list _ 1} 2) '(2 1))) ;; rcurry.1
12.39- (is (equal (mapcar {- _ 1} '(1 2 3 4)) '(0 1 2 3))) ;; rcurry.2
12.40- (is (equal (funcall [{* 3} #'1+] 1) 6)) ;; compose.1
12.41- (is (equal (funcall ['1+ '1+] 1) 3)) ;; compose.2
12.42- (is (equal (funcall [#'1+] 1) 2)) ;; compose.3
12.43- (is (equal (funcall [#'values] 1 2 3) (values 1 2 3))) ;; compose.4
12.44- (is (equal (funcall «list {* 2} {* 3}» 4) '(8 12))) ;; join.1
12.45- (is (equal (mapcar «and {< 2} 'evenp (constantly t)» '(1 2 3 4)) (list nil nil nil t))) ;; join.2
12.46- ;; typecase-bracket
12.47- (is (equal (mapcar ‹typecase (number #'1+) (string :str)› '(1 "this" 2 "that")) '(2 :str 3 :str)))
12.48- ;; cond-bracket
12.49- (is (equal (mapcar ‹cond (#'evenp {+ 100}) (#'oddp {+ 200})› '(1 2 3 4)) '(201 102 203 104)))
12.50- ;; if-bracket
12.51- (is (equal (mapcar ‹if #'evenp {list :a} {list :b}› '(1 2 3 4))
12.52- '((:b 1) (:a 2) (:b 3) (:a 4))))
12.53- ;; when-bracket
12.54- (is (equal (mapcar ‹when 'evenp {+ 4}› '(1 2 3 4)) (list nil 6 nil 8)))
12.55- ;; unless-bracket
12.56- (is (equal (mapcar ‹unless 'evenp {+ 4}› '(1 2 3 4)) (list 5 nil 7 nil))))
12.57-
12.58-(deftest sym ()
12.59- "Test standard symbol utils"
12.60- ;; gensyms
12.61- (is (not (equalp (make-gensym 'a) (make-gensym 'a))))
12.62- (is (eq 'std/tests::foo (format-symbol :std/tests "~A" 'foo)))
12.63- (is (eq (make-keyword 'fizz) :fizz)))
12.64-
12.65-;;;; TODO
12.66-(deftest string ()
12.67- "Test standard string utils"
12.68- (is (typep "test" 'string-designator))
12.69- (is (typep 'test 'string-designator))
12.70- (is (typep #\C 'string-designator))
12.71- (is (not (typep 0 'string-designator))))
12.72-
12.73-(deftest list ()
12.74- "Test standard list utils"
12.75- ;; same object - a literal
12.76- (is (eq (ensure-car '(0)) (ensure-car 0)))
12.77- (is (eq (ensure-car '(nil)) (ensure-car nil)))
12.78- ;; different objects
12.79- (is (not (eq (ensure-cons 0) (ensure-cons 0))))
12.80- (is (equal (ensure-cons 0) (ensure-cons 0))))
12.81-
12.82-(deftest err ()
12.83- "Test standard error handlers"
12.84- (is (eql 'testing-err (deferror testing-err (std-error) nil (:auto t) (:documentation "testing")))))
12.85-
12.86-(deftest threads ()
12.87- "Test standard thread functionality."
12.88- (is (eq *current-thread*
12.89- (find (thread-name *current-thread*) (list-all-threads)
12.90- :key #'thread-name :test #'equal)))
12.91- (is (find-thread-by-id (car (thread-id-list))))
12.92- (is (not (zerop (thread-count))))
12.93- (let ((threads
12.94- (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads")))
12.95- (loop for th in threads
12.96- do (sb-thread:join-thread th))
12.97- (loop for th in threads
12.98- collect (is (not (sb-thread:thread-alive-p th)))))
12.99- (let ((m (make-mutex :name "mutex-test")))
12.100- (is
12.101- (and (not
12.102- (with-mutex (m)
12.103- (join-thread
12.104- (make-thread (lambda ()
12.105- (with-mutex (m :timeout 0.1)
12.106- t))))))
12.107- (join-thread
12.108- (make-thread (lambda ()
12.109- (with-mutex (m :timeout 0.1)
12.110- t)))))))
12.111- (let* ((sym (gensym))
12.112- (s (make-semaphore :name "semaphore-test"))
12.113- (th (make-thread (lambda () (wait-on-semaphore s)))))
12.114- (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym))
12.115- (list sym :timeout)))
12.116- (signal-semaphore s)
12.117- (is (join-thread th)))
12.118- (signals join-thread-error (join-thread *current-thread*))
12.119- (is
12.120- (let ((m (make-mutex :name "rlock-test")))
12.121- (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))))
12.122- (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))
12.123- (let ((queue (make-waitqueue :name "queue-test"))
12.124- (lock (make-mutex :name "lock-test"))
12.125- (n 0)
12.126- th)
12.127- (labels ((in-new-thread ()
12.128- (with-mutex (lock)
12.129- (assert (eql (mutex-owner lock) *current-thread*))
12.130- (condition-wait queue lock)
12.131- (assert (eql (mutex-owner lock) *current-thread*))
12.132- (is (= n 1))
12.133- (decf n))))
12.134- (setf th (make-thread #'in-new-thread))
12.135- (sleep 1)
12.136- (is (null (mutex-owner lock)))
12.137- (with-mutex (lock)
12.138- (incf n)
12.139- (condition-notify queue))
12.140- (is (= 0 (join-thread th))))))
12.141-
12.142-(deftest timers ()
12.143- "Test various timer functionality."
12.144- (sb-int:with-progressive-timeout (ttl :seconds 2)
12.145- (sleep 0.1)
12.146- (is (/= (ttl) 2.0))))
12.147-
12.148-(deftest tasks ()
12.149- "Test task-pools, oracles, and workers."
12.150- (let ((pool (designate-oracle (make-task-pool) (make-oracle *current-thread*))))
12.151- ;; pool is bound to a task pool, *ORACLE-THREADS* contains the *CURRENT-THREAD*.
12.152- (spawn-workers pool 16)
12.153- ;; (with-threads (16 :args (&optional (a 0) (b 1) (c 2)))
12.154- ;; (sb-thread:allocator-histogram)
12.155- ;; (sb-concurrency:wait-on-gate (std/thread::task-pool-online pool))
12.156- ;; (print (+ a b c)))
12.157- (is (= 16 (length (task-pool-workers pool))))
12.158- (is (sb-thread:semaphore-count (std/task::task-pool-online pool)))))
12.159-
12.160-(deftest fmt ()
12.161- "Test standard formatters"
12.162- (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3))))
12.163- (is (string=
12.164- ;; note the read-time-eval..
12.165- #.(fmt-tree nil '(foobar (:a) (:b) (c) (d)) :layout :down)
12.166- #"FOOBAR
12.167- ├─ :A
12.168- ├─ :B
12.169- ├─ C
12.170- ╰─ D
12.171-"#))
12.172- ;; with plist option
12.173- (is (string=
12.174- #.(std:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
12.175- #"SK-PROJECT
12.176- ├─ :NAME
12.177- │ ╰─ "foobar"
12.178- ├─ :PATH
12.179- │ ╰─ "/a/b/c.asd"
12.180- ╰─ :VC
12.181- ╰─ :HG
12.182-"#)))
12.183-
12.184-(deftest ana ()
12.185- "Test standard anaphoric macros"
12.186- (is (= 8
12.187- (aif (+ 2 2)
12.188- (+ it it))))
12.189- (is (= 42 (awhen 42 it)))
12.190- (is (= 3 (acond ((1+ 1) (1+ it)))))
12.191- (loop for x in '(1 2 3)
12.192- for y in (funcall (alet ((a 1) (b 2) (c 3))
12.193- (lambda () (mapc #'1+ (list a b c)))))
12.194- collect (is (= x y))))
12.195-
12.196-(deftest pan ()
12.197- "Test standard pandoric macros"
12.198- (let ((p
12.199- (plambda (a) (b c)
12.200- (if (not a)
12.201- (setq b 0
12.202- c 0)
12.203- (progn (incf b a) (incf c a))))))
12.204- (with-pandoric (b c) p
12.205- (is (= 0 (funcall p nil)))
12.206- (is (= 1 (funcall p 1)))
12.207- (is (= 11 (funcall p 10)))
12.208- (is (= 0 (funcall p nil)))
12.209- )))
12.210-
12.211-(deftest alien ()
12.212- "Test standard alien utils"
12.213- (is (= 0 (foreign-int-to-integer 0 4)))
12.214- (is (= 1 (bool-to-foreign-int t))))
12.215-
12.216-(deftest curry ()
12.217- "Test curry functions from Alexandria, found in std/fu.
12.218-These tests are copied directly from the Alexandria test suite."
12.219- ;; curry.1
12.220- (let ((curried (curry '+ 3)))
12.221- (is (= (funcall curried 1 5) 9)))
12.222- ;; curry.2
12.223- (let ((curried (locally (declare (notinline curry))
12.224- (curry '* 2 3))))
12.225- (is (= (funcall curried 7) 42)))
12.226- ;; curry.3
12.227- (let ((curried-form (funcall (compiler-macro-function 'curry)
12.228- '(curry '/ 8)
12.229- nil)))
12.230- (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
12.231- (is (= (funcall fun 2) 4)))) ;; maybe fails?
12.232- ;; curry.4
12.233- (let* ((x 1)
12.234- (curried (curry (progn
12.235- (incf x)
12.236- (lambda (y z) (* x y z)))
12.237- 3)))
12.238- (is (equal (list (funcall curried 7)
12.239- (funcall curried 7)
12.240- x)
12.241- '(42 42 2))))
12.242- ;; rcurry.1
12.243- (let ((r (rcurry '/ 2)))
12.244- (is (= (funcall r 8) 4)))
12.245- ;; rcurry.2
12.246- (let* ((x 1)
12.247- (curried (rcurry (progn
12.248- (incf x)
12.249- (lambda (y z) (* x y z)))
12.250- 3)))
12.251- (is (equalp
12.252- (list (funcall curried 7) ;; 42
12.253- (funcall curried 7) ;; 42
12.254- x) ;; 2
12.255- '(42 42 2)))))
12.256-
12.257-(define-bitfield testbits
12.258- (a boolean)
12.259- (b (signed-byte 2))
12.260- (c (unsigned-byte 3) :initform 1)
12.261- (d (integer -100 100))
12.262- (e (member foo bar baz)))
12.263-
12.264-(deftest bits ()
12.265- (let ((bits (make-testbits)))
12.266- (is (not (testbits-a bits)))
12.267- (is (= 0 (testbits-b bits)))
12.268- (is (= 1 (testbits-c bits)))
12.269- (is (= -100 (testbits-d bits)))
12.270- (is (eql 'foo (testbits-e bits)))))
12.271-
12.272-(deftest leb128 ()
12.273- (loop for i from 0 below 1000
12.274- do (is (= i (decode-uleb128 (encode-uleb128 i)))))
12.275- (signals division-by-zero (decode-uleb128 (encode-uleb128 -1)))
12.276- (loop for i from -1000 below 0
12.277- do (is (= i (decode-leb128 (encode-leb128 i))))
12.278- do (is (= (* i i) (decode-leb128 (encode-leb128 (* i i)))))))
12.279-
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/lisp/std/tests/num.lisp Sun Jul 28 20:49:47 2024 -0400
13.3@@ -0,0 +1,15 @@
13.4+;;; num.lisp --- Number Tests
13.5+
13.6+;;
13.7+
13.8+;;; Code:
13.9+(in-package :std/tests)
13.10+(in-suite :std)
13.11+
13.12+(deftest leb128 ()
13.13+ (loop for i from 0 below 1000
13.14+ do (is (= i (decode-uleb128 (encode-uleb128 i)))))
13.15+ (signals division-by-zero (decode-uleb128 (encode-uleb128 -1)))
13.16+ (loop for i from -1000 below 0
13.17+ do (is (= i (decode-leb128 (encode-leb128 i))))
13.18+ do (is (= (* i i) (decode-leb128 (encode-leb128 (* i i)))))))
14.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2+++ b/lisp/std/tests/pkg.lisp Sun Jul 28 20:49:47 2024 -0400
14.3@@ -0,0 +1,255 @@
14.4+;;; tests.lisp --- std system tests
14.5+
14.6+;;; Commentary:
14.7+
14.8+;; TODO: fix false positives when using (eval-test)
14.9+
14.10+;;; Code:
14.11+(in-package :std-int)
14.12+(defpkg :std/tests
14.13+ (:use :cl :std :rt :sb-thread :std/fu))
14.14+(in-package :std/tests)
14.15+(defsuite :std)
14.16+(in-suite :std)
14.17+(in-readtable :std)
14.18+;; prevent threadlocks
14.19+;; (setf sb-unix::*on-dangerous-wait* :error)
14.20+
14.21+;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
14.22+(deftest readtables (:skip nil)
14.23+ "Test :std readtable"
14.24+ (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
14.25+ (is (string= #"test "foo" "# "test \"foo\" "))
14.26+ ;; from curry-compose-reader-macros test suite
14.27+ (is (equal (funcall {list 1} 2) '(1 2))) ;; curry.1
14.28+ (is (equal (mapcar {+ 1} '(1 2 3 4)) '(2 3 4 5))) ;; curry.2
14.29+ (is (equal (funcall {1 list 1} 2) '(1 2))) ;; curry.fixed-arity
14.30+ (is (equal (funcall {2 list _ 2} 3 4) '(3 4 2))) ;; curry.fixed-arity.2
14.31+ (signals error
14.32+ (let ((f {1 list 1}))
14.33+ (progn (funcall f) nil))) ;; curry.fixed-arity.1
14.34+ (signals error
14.35+ (locally (declare (optimize safety))
14.36+ (let ((f {1 list 1}))
14.37+ (progn (funcall f 'a 'b) nil)))) ;; curry.fixed-arity-error.2
14.38+ (is (equal (funcall {list _ 1} 2) '(2 1))) ;; rcurry.1
14.39+ (is (equal (mapcar {- _ 1} '(1 2 3 4)) '(0 1 2 3))) ;; rcurry.2
14.40+ (is (equal (funcall [{* 3} #'1+] 1) 6)) ;; compose.1
14.41+ (is (equal (funcall ['1+ '1+] 1) 3)) ;; compose.2
14.42+ (is (equal (funcall [#'1+] 1) 2)) ;; compose.3
14.43+ (is (equal (funcall [#'values] 1 2 3) (values 1 2 3))) ;; compose.4
14.44+ (is (equal (funcall «list {* 2} {* 3}» 4) '(8 12))) ;; join.1
14.45+ (is (equal (mapcar «and {< 2} 'evenp (constantly t)» '(1 2 3 4)) (list nil nil nil t))) ;; join.2
14.46+ ;; typecase-bracket
14.47+ (is (equal (mapcar ‹typecase (number #'1+) (string :str)› '(1 "this" 2 "that")) '(2 :str 3 :str)))
14.48+ ;; cond-bracket
14.49+ (is (equal (mapcar ‹cond (#'evenp {+ 100}) (#'oddp {+ 200})› '(1 2 3 4)) '(201 102 203 104)))
14.50+ ;; if-bracket
14.51+ (is (equal (mapcar ‹if #'evenp {list :a} {list :b}› '(1 2 3 4))
14.52+ '((:b 1) (:a 2) (:b 3) (:a 4))))
14.53+ ;; when-bracket
14.54+ (is (equal (mapcar ‹when 'evenp {+ 4}› '(1 2 3 4)) (list nil 6 nil 8)))
14.55+ ;; unless-bracket
14.56+ (is (equal (mapcar ‹unless 'evenp {+ 4}› '(1 2 3 4)) (list 5 nil 7 nil))))
14.57+
14.58+(deftest sym ()
14.59+ "Test standard symbol utils"
14.60+ ;; gensyms
14.61+ (is (not (equalp (make-gensym 'a) (make-gensym 'a))))
14.62+ (is (eq 'std/tests::foo (format-symbol :std/tests "~A" 'foo)))
14.63+ (is (eq (make-keyword 'fizz) :fizz)))
14.64+
14.65+;;;; TODO
14.66+(deftest string ()
14.67+ "Test standard string utils"
14.68+ (is (typep "test" 'string-designator))
14.69+ (is (typep 'test 'string-designator))
14.70+ (is (typep #\C 'string-designator))
14.71+ (is (not (typep 0 'string-designator))))
14.72+
14.73+(deftest list ()
14.74+ "Test standard list utils"
14.75+ ;; same object - a literal
14.76+ (is (eq (ensure-car '(0)) (ensure-car 0)))
14.77+ (is (eq (ensure-car '(nil)) (ensure-car nil)))
14.78+ ;; different objects
14.79+ (is (not (eq (ensure-cons 0) (ensure-cons 0))))
14.80+ (is (equal (ensure-cons 0) (ensure-cons 0))))
14.81+
14.82+(deftest err ()
14.83+ "Test standard error handlers"
14.84+ (is (eql 'testing-err (deferror testing-err (std-error) nil (:auto t) (:documentation "testing")))))
14.85+
14.86+(deftest threads ()
14.87+ "Test standard thread functionality."
14.88+ (is (eq *current-thread*
14.89+ (find (thread-name *current-thread*) (list-all-threads)
14.90+ :key #'thread-name :test #'equal)))
14.91+ (is (find-thread-by-id (car (thread-id-list))))
14.92+ (is (not (zerop (thread-count))))
14.93+ (let ((threads
14.94+ (make-threads 4 (lambda () (is (= 42 (1+ 41)))) :name "threads")))
14.95+ (loop for th in threads
14.96+ do (sb-thread:join-thread th))
14.97+ (loop for th in threads
14.98+ collect (is (not (sb-thread:thread-alive-p th)))))
14.99+ (let ((m (make-mutex :name "mutex-test")))
14.100+ (is
14.101+ (and (not
14.102+ (with-mutex (m)
14.103+ (join-thread
14.104+ (make-thread (lambda ()
14.105+ (with-mutex (m :timeout 0.1)
14.106+ t))))))
14.107+ (join-thread
14.108+ (make-thread (lambda ()
14.109+ (with-mutex (m :timeout 0.1)
14.110+ t)))))))
14.111+ (let* ((sym (gensym))
14.112+ (s (make-semaphore :name "semaphore-test"))
14.113+ (th (make-thread (lambda () (wait-on-semaphore s)))))
14.114+ (is (equal (multiple-value-list (join-thread th :timeout .001 :default sym))
14.115+ (list sym :timeout)))
14.116+ (signal-semaphore s)
14.117+ (is (join-thread th)))
14.118+ (signals join-thread-error (join-thread *current-thread*))
14.119+ (is
14.120+ (let ((m (make-mutex :name "rlock-test")))
14.121+ (is (not (with-mutex (m) (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t)))))))
14.122+ (join-thread (make-thread (lambda () (with-recursive-lock (m :wait-p nil) t))))))
14.123+ (let ((queue (make-waitqueue :name "queue-test"))
14.124+ (lock (make-mutex :name "lock-test"))
14.125+ (n 0)
14.126+ th)
14.127+ (labels ((in-new-thread ()
14.128+ (with-mutex (lock)
14.129+ (assert (eql (mutex-owner lock) *current-thread*))
14.130+ (condition-wait queue lock)
14.131+ (assert (eql (mutex-owner lock) *current-thread*))
14.132+ (is (= n 1))
14.133+ (decf n))))
14.134+ (setf th (make-thread #'in-new-thread))
14.135+ (sleep 1)
14.136+ (is (null (mutex-owner lock)))
14.137+ (with-mutex (lock)
14.138+ (incf n)
14.139+ (condition-notify queue))
14.140+ (is (= 0 (join-thread th))))))
14.141+
14.142+(deftest timers ()
14.143+ "Test various timer functionality."
14.144+ (sb-int:with-progressive-timeout (ttl :seconds 2)
14.145+ (sleep 0.1)
14.146+ (is (/= (ttl) 2.0))))
14.147+
14.148+(deftest fmt ()
14.149+ "Test standard formatters"
14.150+ (is (string= (format nil "| 1 | 2 | 3 |~%") (fmt-row '(1 2 3))))
14.151+ (is (string=
14.152+ ;; note the read-time-eval..
14.153+ #.(fmt-tree nil '(foobar (:a) (:b) (c) (d)) :layout :down)
14.154+ #"FOOBAR
14.155+ ├─ :A
14.156+ ├─ :B
14.157+ ├─ C
14.158+ ╰─ D
14.159+"#))
14.160+ ;; with plist option
14.161+ (is (string=
14.162+ #.(std:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
14.163+ #"SK-PROJECT
14.164+ ├─ :NAME
14.165+ │ ╰─ "foobar"
14.166+ ├─ :PATH
14.167+ │ ╰─ "/a/b/c.asd"
14.168+ ╰─ :VC
14.169+ ╰─ :HG
14.170+"#)))
14.171+
14.172+(deftest ana ()
14.173+ "Test standard anaphoric macros"
14.174+ (is (= 8
14.175+ (aif (+ 2 2)
14.176+ (+ it it))))
14.177+ (is (= 42 (awhen 42 it)))
14.178+ (is (= 3 (acond ((1+ 1) (1+ it)))))
14.179+ (loop for x in '(1 2 3)
14.180+ for y in (funcall (alet ((a 1) (b 2) (c 3))
14.181+ (lambda () (mapc #'1+ (list a b c)))))
14.182+ collect (is (= x y))))
14.183+
14.184+(deftest pan ()
14.185+ "Test standard pandoric macros"
14.186+ (let ((p
14.187+ (plambda (a) (b c)
14.188+ (if (not a)
14.189+ (setq b 0
14.190+ c 0)
14.191+ (progn (incf b a) (incf c a))))))
14.192+ (with-pandoric (b c) p
14.193+ (is (= 0 (funcall p nil)))
14.194+ (is (= 1 (funcall p 1)))
14.195+ (is (= 11 (funcall p 10)))
14.196+ (is (= 0 (funcall p nil)))
14.197+ )))
14.198+
14.199+(deftest alien ()
14.200+ "Test standard alien utils"
14.201+ (is (= 0 (foreign-int-to-integer 0 4)))
14.202+ (is (= 1 (bool-to-foreign-int t))))
14.203+
14.204+(deftest curry ()
14.205+ "Test curry functions from Alexandria, found in std/fu.
14.206+These tests are copied directly from the Alexandria test suite."
14.207+ ;; curry.1
14.208+ (let ((curried (curry '+ 3)))
14.209+ (is (= (funcall curried 1 5) 9)))
14.210+ ;; curry.2
14.211+ (let ((curried (locally (declare (notinline curry))
14.212+ (curry '* 2 3))))
14.213+ (is (= (funcall curried 7) 42)))
14.214+ ;; curry.3
14.215+ (let ((curried-form (funcall (compiler-macro-function 'curry)
14.216+ '(curry '/ 8)
14.217+ nil)))
14.218+ (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
14.219+ (is (= (funcall fun 2) 4)))) ;; maybe fails?
14.220+ ;; curry.4
14.221+ (let* ((x 1)
14.222+ (curried (curry (progn
14.223+ (incf x)
14.224+ (lambda (y z) (* x y z)))
14.225+ 3)))
14.226+ (is (equal (list (funcall curried 7)
14.227+ (funcall curried 7)
14.228+ x)
14.229+ '(42 42 2))))
14.230+ ;; rcurry.1
14.231+ (let ((r (rcurry '/ 2)))
14.232+ (is (= (funcall r 8) 4)))
14.233+ ;; rcurry.2
14.234+ (let* ((x 1)
14.235+ (curried (rcurry (progn
14.236+ (incf x)
14.237+ (lambda (y z) (* x y z)))
14.238+ 3)))
14.239+ (is (equalp
14.240+ (list (funcall curried 7) ;; 42
14.241+ (funcall curried 7) ;; 42
14.242+ x) ;; 2
14.243+ '(42 42 2)))))
14.244+
14.245+(define-bitfield testbits
14.246+ (a boolean)
14.247+ (b (signed-byte 2))
14.248+ (c (unsigned-byte 3) :initform 1)
14.249+ (d (integer -100 100))
14.250+ (e (member foo bar baz)))
14.251+
14.252+(deftest bits ()
14.253+ (let ((bits (make-testbits)))
14.254+ (is (not (testbits-a bits)))
14.255+ (is (= 0 (testbits-b bits)))
14.256+ (is (= 1 (testbits-c bits)))
14.257+ (is (= -100 (testbits-d bits)))
14.258+ (is (eql 'foo (testbits-e bits)))))
15.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2+++ b/lisp/std/tests/task.lisp Sun Jul 28 20:49:47 2024 -0400
15.3@@ -0,0 +1,19 @@
15.4+;;; tests/task.lisp --- Task Tests
15.5+
15.6+;;
15.7+
15.8+;;; Code:
15.9+(in-package :std/tests)
15.10+(in-suite :std)
15.11+
15.12+(deftest tasks ()
15.13+ "Test task-pools, oracles, and workers."
15.14+ (let ((pool (designate-oracle (make-task-pool) (make-oracle *current-thread*))))
15.15+ ;; pool is bound to a task pool, *ORACLE-THREADS* contains the *CURRENT-THREAD*.
15.16+ (spawn-workers pool 16)
15.17+ ;; (with-threads (16 :args (&optional (a 0) (b 1) (c 2)))
15.18+ ;; (sb-thread:allocator-histogram)
15.19+ ;; (sb-concurrency:wait-on-gate (std/thread::task-pool-online pool))
15.20+ ;; (print (+ a b c)))
15.21+ (is (= 16 (length (task-pool-workers pool))))
15.22+ (is (sb-thread:semaphore-count (std/task::task-pool-online pool)))))
16.1--- a/lisp/std/tests/tasks.lisp Sat Jul 27 00:40:29 2024 -0400
16.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
16.3@@ -1,7 +0,0 @@
16.4-;;; tasks.lisp --- Task Pool Tests
16.5-
16.6-;;
16.7-
16.8-;;; Code:
16.9-(in-package :std/tests)
16.10-(in-suite :std)
