3rdparties/software/alexandria-20200427-git/alexandria-1/types.lisp (5864 bytes)
1 (in-package :alexandria) 2 3 (deftype array-index (&optional (length (1- array-dimension-limit))) 4 "Type designator for an index into array of LENGTH: an integer between 5 0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than 6 ARRAY-DIMENSION-LIMIT." 7 `(integer 0 (,length))) 8 9 (deftype array-length (&optional (length (1- array-dimension-limit))) 10 "Type designator for a dimension of an array of LENGTH: an integer between 11 0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than 12 ARRAY-DIMENSION-LIMIT." 13 `(integer 0 ,length)) 14 15 ;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/) 16 ;; except the RATIO related definitions and ARRAY-INDEX. 17 (macrolet 18 ((frob (type &optional (base-type type)) 19 (let ((subtype-names (list)) 20 (predicate-names (list))) 21 (flet ((make-subtype-name (format-control) 22 (let ((result (format-symbol :alexandria format-control 23 (symbol-name type)))) 24 (push result subtype-names) 25 result)) 26 (make-predicate-name (sybtype-name) 27 (let ((result (format-symbol :alexandria '#:~A-p 28 (symbol-name sybtype-name)))) 29 (push result predicate-names) 30 result)) 31 (make-docstring (range-beg range-end range-type) 32 (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf")))) 33 (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A." 34 type 35 (if (equal range-beg ''*) inf (ensure-car range-beg)) 36 (if (equal range-end ''*) inf (ensure-car range-end)))))) 37 (let* ((negative-name (make-subtype-name '#:negative-~a)) 38 (non-positive-name (make-subtype-name '#:non-positive-~a)) 39 (non-negative-name (make-subtype-name '#:non-negative-~a)) 40 (positive-name (make-subtype-name '#:positive-~a)) 41 (negative-p-name (make-predicate-name negative-name)) 42 (non-positive-p-name (make-predicate-name non-positive-name)) 43 (non-negative-p-name (make-predicate-name non-negative-name)) 44 (positive-p-name (make-predicate-name positive-name)) 45 (negative-extremum) 46 (positive-extremum) 47 (below-zero) 48 (above-zero) 49 (zero)) 50 (setf (values negative-extremum below-zero 51 above-zero positive-extremum zero) 52 (ecase type 53 (fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0)) 54 (integer (values ''* -1 1 ''* 0)) 55 (rational (values ''* '(0) '(0) ''* 0)) 56 (real (values ''* '(0) '(0) ''* 0)) 57 (float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0)) 58 (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0)) 59 (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0)) 60 (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0)) 61 (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0)))) 62 `(progn 63 (deftype ,negative-name () 64 ,(make-docstring negative-extremum below-zero :negative) 65 `(,',base-type ,,negative-extremum ,',below-zero)) 66 67 (deftype ,non-positive-name () 68 ,(make-docstring negative-extremum zero :negative) 69 `(,',base-type ,,negative-extremum ,',zero)) 70 71 (deftype ,non-negative-name () 72 ,(make-docstring zero positive-extremum :positive) 73 `(,',base-type ,',zero ,,positive-extremum)) 74 75 (deftype ,positive-name () 76 ,(make-docstring above-zero positive-extremum :positive) 77 `(,',base-type ,',above-zero ,,positive-extremum)) 78 79 (declaim (inline ,@predicate-names)) 80 81 (defun ,negative-p-name (n) 82 (and (typep n ',type) 83 (< n ,zero))) 84 85 (defun ,non-positive-p-name (n) 86 (and (typep n ',type) 87 (<= n ,zero))) 88 89 (defun ,non-negative-p-name (n) 90 (and (typep n ',type) 91 (<= ,zero n))) 92 93 (defun ,positive-p-name (n) 94 (and (typep n ',type) 95 (< ,zero n))))))))) 96 (frob fixnum integer) 97 (frob integer) 98 (frob rational) 99 (frob real) 100 (frob float) 101 (frob short-float) 102 (frob single-float) 103 (frob double-float) 104 (frob long-float)) 105 106 (defun of-type (type) 107 "Returns a function of one argument, which returns true when its argument is 108 of TYPE." 109 (lambda (thing) (typep thing type))) 110 111 (define-compiler-macro of-type (&whole form type &environment env) 112 ;; This can yeild a big benefit, but no point inlining the function 113 ;; all over the place if TYPE is not constant. 114 (if (constantp type env) 115 (with-gensyms (thing) 116 `(lambda (,thing) 117 (typep ,thing ,type))) 118 form)) 119 120 (declaim (inline type=)) 121 (defun type= (type1 type2) 122 "Returns a primary value of T is TYPE1 and TYPE2 are the same type, 123 and a secondary value that is true is the type equality could be reliably 124 determined: primary value of NIL and secondary value of T indicates that the 125 types are not equivalent." 126 (multiple-value-bind (sub ok) (subtypep type1 type2) 127 (cond ((and ok sub) 128 (subtypep type2 type1)) 129 (ok 130 (values nil ok)) 131 (t 132 (multiple-value-bind (sub ok) (subtypep type2 type1) 133 (declare (ignore sub)) 134 (values nil ok)))))) 135 136 (define-modify-macro coercef (type-spec) coerce 137 "Modify-macro for COERCE.")