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            (let* ((negative-name     (make-subtype-name "NEGATIVE-~A"))
  32                   (non-positive-name (make-subtype-name "NON-POSITIVE-~A"))
  33                   (non-negative-name (make-subtype-name "NON-NEGATIVE-~A"))
  34                   (positive-name     (make-subtype-name "POSITIVE-~A"))
  35                   (negative-p-name     (make-predicate-name negative-name))
  36                   (non-positive-p-name (make-predicate-name non-positive-name))
  37                   (non-negative-p-name (make-predicate-name non-negative-name))
  38                   (positive-p-name     (make-predicate-name positive-name))
  39                   (negative-extremum)
  40                   (positive-extremum)
  41                   (below-zero)
  42                   (above-zero)
  43                   (zero))
  44              (setf (values negative-extremum below-zero
  45                            above-zero positive-extremum zero)
  46                    (ecase type
  47                      (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
  48                      (integer      (values ''* -1 1 ''* 0))
  49                      (rational     (values ''* ''(0) ''(0) ''* 0))
  50                      (real         (values ''* ''(0) ''(0) ''* 0))
  51                      (float        (values ''* ''(0.0E0) ''(0.0E0) ''* 0.0E0))
  52                      (short-float  (values ''* ''(0.0S0) ''(0.0S0) ''* 0.0S0))
  53                      (single-float (values ''* ''(0.0F0) ''(0.0F0) ''* 0.0F0))
  54                      (double-float (values ''* ''(0.0D0) ''(0.0D0) ''* 0.0D0))
  55                      (long-float   (values ''* ''(0.0L0) ''(0.0L0) ''* 0.0L0))))
  56              `(progn
  57                 (deftype ,negative-name ()
  58                   `(,',base-type ,,negative-extremum ,,below-zero))
  59
  60                 (deftype ,non-positive-name ()
  61                   `(,',base-type ,,negative-extremum ,,zero))
  62
  63                 (deftype ,non-negative-name ()
  64                   `(,',base-type ,,zero ,,positive-extremum))
  65
  66                 (deftype ,positive-name ()
  67                   `(,',base-type ,,above-zero ,,positive-extremum))
  68
  69                 (declaim (inline ,@predicate-names))
  70
  71                 (defun ,negative-p-name (n)
  72                   (and (typep n ',type)
  73                        (< n ,zero)))
  74
  75                 (defun ,non-positive-p-name (n)
  76                   (and (typep n ',type)
  77                        (<= n ,zero)))
  78
  79                 (defun ,non-negative-p-name (n)
  80                   (and (typep n ',type)
  81                        (<= ,zero n)))
  82
  83                 (defun ,positive-p-name (n)
  84                   (and (typep n ',type)
  85                        (< ,zero n)))
  86
  87                 (export ',subtype-names :alexandria)
  88                 (export ',predicate-names :alexandria)))))))
  89   (frob fixnum integer)
  90   (frob integer)
  91   (frob rational)
  92   (frob real)
  93   (frob float)
  94   (frob short-float)
  95   (frob single-float)
  96   (frob double-float)
  97   (frob long-float))
  98
  99 (defun of-type (type)
 100   "Returns a function of one argument, which returns true when its argument is
 101 of TYPE."
 102   (lambda (thing) (typep thing type)))
 103
 104 (define-compiler-macro of-type (&whole form type &environment env)
 105   ;; This can yeild a big benefit, but no point inlining the function
 106   ;; all over the place if TYPE is not constant.
 107   (if (constantp type env)
 108       (with-gensyms (thing)
 109         `(lambda (,thing)
 110            (typep ,thing ,type)))
 111       form))
 112
 113 (declaim (inline type=))
 114 (defun type= (type1 type2)
 115   "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
 116 and a secondary value that is true is the type equality could be reliably
 117 determined: primary value of NIL and secondary value of T indicates that the
 118 types are not equivalent."
 119   (multiple-value-bind (sub ok) (subtypep type1 type2)
 120     (cond ((and ok sub)
 121            (subtypep type2 type1))
 122           (ok
 123            (values nil ok))
 124           (t
 125            (multiple-value-bind (sub ok) (subtypep type2 type1)
 126              (declare (ignore sub))
 127              (values nil ok))))))
 128
 129 (define-modify-macro coercef (type-spec) coerce
 130   "Modify-macro for COERCE.")