Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/alexandria-20241012-git/alexandria-1/types.lisp

KindCoveredAll%
expression057 0.0
branch08 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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 if 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) ; type1 is known to be a subtype of type 2
128
            ; so type= return values come from the second invocation of subtypep
129
            (subtypep type2 type1))
130
           ;; type1 is assuredly NOT a subtype of type2,
131
           ;; so assuredly type1 and type2 cannot be type=
132
           (ok
133
            (values nil t))
134
           ;; our first result is uncertain ( ok == nil ) and it follows
135
           ;; from specification of SUBTYPEP that sub = ok = NIL
136
           (t
137
            (assert (not sub))           ; is the implementation correct?
138
            (multiple-value-bind (sub2 ok2)
139
                (subtypep type2 type1)
140
              (if  (and (not sub2) ok2)  ; we KNOW type2 is not a subtype of type1
141
                   ;; so our results are certain...
142
                   (values nil t)
143
                   ;; otherwise, either type2 is surely a subtype of type1 (t t)
144
                   ;; or type2 is not a subtype of type1, but we don't
145
                   ;; know that for sure (nil nil)
146
                   ;; In either case our result is negative but unsure
147
                   (values nil nil)))))))
148
 
149
 (define-modify-macro coercef (type-spec) coerce
150
   "Modify-macro for COERCE.")