types.lisp

   1 (in-package :alexandria)
   2
   3 (deftype array-index (&optional (length 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
   6 ARRAY-DIMENSION-LIMIT."
   7   `(integer 0 (,length)))
   8
   9 (deftype array-length (&optional (length 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
  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.")