Coverage report: /home/ellis/comp/core/std/type.lisp

KindCoveredAll%
expression082 0.0
branch08 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/types.lisp --- Standard Types
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/type)
7
 
8
 ;; Bytes aren't necessarily 8 bits wide in Lisp. OCTET is always 8
9
 ;; bits.
10
 (deftype octet () 
11
   "An 8-bit unsigned-byte."
12
   '(unsigned-byte 8))
13
   
14
 (deftype octet-vector (&optional length)
15
   "A simple-array of OCTETs."
16
   (if length `(simple-array octet (,length))
17
       `(simple-vector octet)))
18
 
19
 (defun octet-vector-p (self &optional length)
20
   "Return T if SELF is an OCTET-VECTOR, optionally with a fixed LENGTH."
21
   (typep self (if length `(octet-vector ,length) 'octet-vector)))
22
 
23
 (defconstant +default-element-type+ 'character
24
   "The default ELEMENT-TYPE used by some array operations.")
25
 
26
 (deftype array-index (&optional (length (1- array-dimension-limit)))
27
   "Type designator for an index into array of LENGTH: an integer between
28
 0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
29
 ARRAY-DIMENSION-LIMIT."
30
   `(integer 0 (,length)))
31
 
32
 (deftype array-length (&optional (length (1- array-dimension-limit)))
33
   "Type designator for a dimension of an array of LENGTH: an integer between
34
 0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
35
 ARRAY-DIMENSION-LIMIT."
36
   `(integer 0 ,length))
37
 
38
 ;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
39
 ;; except the RATIO related definitions and ARRAY-INDEX.
40
 (macrolet
41
     ((frob (type &optional (base-type type))
42
        (let ((subtype-names (list))
43
              (predicate-names (list)))
44
          (flet ((make-subtype-name (format-control)
45
                   (let ((result (format-symbol :std format-control
46
                                                (symbol-name type))))
47
                     (push result subtype-names)
48
                     result))
49
                 (make-predicate-name (sybtype-name)
50
                   (let ((result (format-symbol :std '#:~A-p
51
                                                (symbol-name sybtype-name))))
52
                     (push result predicate-names)
53
                     result))
54
                 (make-docstring (range-beg range-end range-type)
55
                   (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
56
                     (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
57
                             type
58
                             (if (equal range-beg ''*) inf (ensure-car range-beg))
59
                             (if (equal range-end ''*) inf (ensure-car range-end)))))
60
                 (make-docstring* (type)
61
                   (format nil "Return Non-nil if N is of type ~A." type)))
62
            (let* ((negative-name     (make-subtype-name '#:negative-~a))
63
                   (non-positive-name (make-subtype-name '#:non-positive-~a))
64
                   (non-negative-name (make-subtype-name '#:non-negative-~a))
65
                   (positive-name     (make-subtype-name '#:positive-~a))
66
                   (negative-p-name     (make-predicate-name negative-name))
67
                   (non-positive-p-name (make-predicate-name non-positive-name))
68
                   (non-negative-p-name (make-predicate-name non-negative-name))
69
                   (positive-p-name     (make-predicate-name positive-name))
70
                   (negative-extremum)
71
                   (positive-extremum)
72
                   (below-zero)
73
                   (above-zero)
74
                   (zero))
75
              (setf (values negative-extremum below-zero
76
                            above-zero positive-extremum zero)
77
                    (ecase type
78
                      (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
79
                      (integer      (values ''* -1       1        ''* 0))
80
                      (rational     (values ''* '(0)     '(0)     ''* 0))
81
                      (real         (values ''* '(0)     '(0)     ''* 0))
82
                      (float        (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
83
                      (short-float  (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
84
                      (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
85
                      (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
86
                      (long-float   (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
87
              `(progn
88
                 (deftype ,negative-name ()
89
                   ,(make-docstring negative-extremum below-zero :negative)
90
                   `(,',base-type ,,negative-extremum ,',below-zero))
91
 
92
                 (deftype ,non-positive-name ()
93
                   ,(make-docstring negative-extremum zero :negative)
94
                   `(,',base-type ,,negative-extremum ,',zero))
95
 
96
                 (deftype ,non-negative-name ()
97
                   ,(make-docstring zero positive-extremum :positive)
98
                   `(,',base-type ,',zero ,,positive-extremum))
99
 
100
                 (deftype ,positive-name ()
101
                   ,(make-docstring above-zero positive-extremum :positive)
102
                   `(,',base-type ,',above-zero ,,positive-extremum))
103
 
104
                 (declaim (inline ,@predicate-names))
105
 
106
                 (defun ,negative-p-name (n)
107
                   ,(make-docstring* negative-name)
108
                   (and (typep n ',type)
109
                        (< n ,zero)))
110
 
111
                 (defun ,non-positive-p-name (n)
112
                   ,(make-docstring* positive-name)
113
                   (and (typep n ',type)
114
                        (<= n ,zero)))
115
 
116
                 (defun ,non-negative-p-name (n)
117
                   ,(make-docstring* non-negative-name)
118
                   (and (typep n ',type)
119
                        (<= ,zero n)))
120
 
121
                 (defun ,positive-p-name (n)
122
                   ,(make-docstring* positive-name)
123
                   (and (typep n ',type)
124
                        (< ,zero n)))))))))
125
   (frob fixnum integer)
126
   (frob integer)
127
   (frob rational)
128
   (frob real)
129
   (frob float)
130
   (frob short-float)
131
   (frob single-float)
132
   (frob double-float)
133
   (frob long-float))
134
 
135
 (defun of-type (type)
136
   "Returns a function of one argument, which returns true when its argument is
137
 of TYPE."
138
   (lambda (thing) (typep thing type)))
139
 
140
 (define-compiler-macro of-type (&whole form type &environment env)
141
   ;; This can yeild a big benefit, but no point inlining the function
142
   ;; all over the place if TYPE is not constant.
143
   (if (constantp type env)
144
       (with-gensyms (thing)
145
         `(lambda (,thing)
146
            (typep ,thing ,type)))
147
       form))
148
 
149
 (definline type-class-of (obj)
150
   "Return the TYPE-CLASS of OBJ."
151
   (type-class (ctype-of obj)))
152
 
153
 (definline type-class-name-of (obj)
154
   "Return the name of the TYPE-CLASS of OBJ."
155
   (type-class-name (type-class-of obj)))
156
 
157
 (definline type-class-id-of (obj)
158
   "Return the ID of the TYPE-CLASS of OBJ."
159
   (type-class-id (ctype-of obj)))
160
 
161
 (definline type= (type1 type2)
162
   "Returns a primary value of T if TYPE1 and TYPE2 are the same type,
163
 and a secondary value that is true is the type equality could be reliably
164
 determined: primary value of NIL and secondary value of T indicates that the
165
 types are not equivalent."
166
   (multiple-value-bind (sub ok) (subtypep type1 type2)
167
     (cond ((and ok sub) ; type1 is known to be a subtype of type 2
168
            ; so type= return values come from the second invocation of subtypep
169
            (subtypep type2 type1))
170
           ;; type1 is assuredly NOT a subtype of type2,
171
           ;; so assuredly type1 and type2 cannot be type=
172
           (ok
173
            (values nil t))
174
           ;; our first result is uncertain ( ok == nil ) and it follows
175
           ;; from specification of SUBTYPEP that sub = ok = NIL
176
           (t
177
            (assert (not sub))           ; is the implementation correct?
178
            (multiple-value-bind (sub2 ok2)
179
                (subtypep type2 type1)
180
              (if  (and (not sub2) ok2)  ; we KNOW type2 is not a subtype of type1
181
                   ;; so our results are certain...
182
                   (values nil t)
183
                   ;; otherwise, either type2 is surely a subtype of type1 (t t)
184
                   ;; or type2 is not a subtype of type1, but we don't
185
                   ;; know that for sure (nil nil)
186
                   ;; In either case our result is negative but unsure
187
                   (values nil nil)))))))
188
 
189
 (define-modify-macro coercef (type-spec) coerce
190
   "Modify-macro for COERCE.")