Squashed 'third_party/lisp/alexandria/' content from commit fc2a2f5c

git-subtree-dir: third_party/lisp/alexandria
git-subtree-split: fc2a2f5c34147bb4e3e4a350b04220de0263710f

1 files changed, 137 insertions, 0 deletions

diff --git a/types.lisp b/types.lisp
new file mode 100644
index 000000000000..1942d0ecdf2a
--- /dev/null
+++ b/types.lisp
@@ -0,0 +1,137 @@
+(in-package :alexandria)
+
+(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 :alexandria format-control
+                                               (symbol-name type))))
+                    (push result subtype-names)
+                    result))
+                (make-predicate-name (sybtype-name)
+                  (let ((result (format-symbol :alexandria '#:~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 is 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)
+           (subtypep type2 type1))
+          (ok
+           (values nil ok))
+          (t
+           (multiple-value-bind (sub ok) (subtypep type2 type1)
+             (declare (ignore sub))
+             (values nil ok))))))
+
+(define-modify-macro coercef (type-spec) coerce
+  "Modify-macro for COERCE.")