types.lisp 5.69 KB
Newer Older
Nikodemus Siivola's avatar
Nikodemus Siivola committed
1 2
(in-package :alexandria)

3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
(deftype array-index (&optional (length array-dimension-limit))
  "Type designator for an index into array of LENGTH: an integer between
0 (inclusive) and LENGTH (exclusive). LENGTH defaults to
ARRAY-DIMENSION-LIMIT."
  `(integer 0 (,length)))

(deftype array-length (&optional (length array-dimension-limit))
  "Type designator for a dimension of an array of LENGTH: an integer between
0 (inclusive) and LENGTH (inclusive). LENGTH defaults to
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)
Andreas Fuchs's avatar
Andreas Fuchs committed
27
                  (let ((result (format-symbol :alexandria '#:~A-p
28 29
                                               (symbol-name sybtype-name))))
                    (push result predicate-names)
30 31 32 33 34 35 36
                    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))))))
37 38 39 40
           (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))
41 42 43 44 45 46 47 48 49 50 51 52 53
                  (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))
54 55 56 57 58 59 60 61
                     (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))))
62 63
             `(progn
                (deftype ,negative-name ()
64 65
		  ,(make-docstring negative-extremum below-zero :negative)
		  `(,',base-type ,,negative-extremum ,',below-zero))
66 67

                (deftype ,non-positive-name ()
68 69
		  ,(make-docstring negative-extremum zero :negative)
		  `(,',base-type ,,negative-extremum ,',zero))
70 71

                (deftype ,non-negative-name ()
72 73
		  ,(make-docstring zero positive-extremum :positive)
		  `(,',base-type ,',zero ,,positive-extremum))
74 75

                (deftype ,positive-name ()
76 77
		  ,(make-docstring above-zero positive-extremum :positive)
		  `(,',base-type ,',above-zero ,,positive-extremum))
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94

                (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)
95
                       (< ,zero n)))))))))
96 97 98 99 100 101 102 103 104 105
  (frob fixnum integer)
  (frob integer)
  (frob rational)
  (frob real)
  (frob float)
  (frob short-float)
  (frob single-float)
  (frob double-float)
  (frob long-float))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
106 107 108 109 110
(defun of-type (type)
  "Returns a function of one argument, which returns true when its argument is
of TYPE."
  (lambda (thing) (typep thing type)))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
111 112 113 114 115 116 117 118 119
(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))

Nikodemus Siivola's avatar
Nikodemus Siivola committed
120 121 122 123 124 125 126 127 128 129 130 131 132
(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)
133
             (declare (ignore sub))
Nikodemus Siivola's avatar
Nikodemus Siivola committed
134
             (values nil ok))))))
Luís Oliveira's avatar
Luís Oliveira committed
135 136 137

(define-modify-macro coercef (type-spec) coerce
  "Modify-macro for COERCE.")