1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
(in-package :alexandria)
(deftype array-index (&optional (length (1- array-dimension-limit)))
"Type designator for an index into array of LENGTH: an integer between
0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
ARRAY-DIMENSION-LIMIT."
`(integer 0 (,length)))
(deftype array-length (&optional (length (1- array-dimension-limit)))
"Type designator for a dimension of an array of LENGTH: an integer between
0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
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)
(let ((result (format-symbol :alexandria '#:~A-p
(symbol-name sybtype-name))))
(push result predicate-names)
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))))))
(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))
(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))
(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))))
`(progn
(deftype ,negative-name ()
,(make-docstring negative-extremum below-zero :negative)
`(,',base-type ,,negative-extremum ,',below-zero))
(deftype ,non-positive-name ()
,(make-docstring negative-extremum zero :negative)
`(,',base-type ,,negative-extremum ,',zero))
(deftype ,non-negative-name ()
,(make-docstring zero positive-extremum :positive)
`(,',base-type ,',zero ,,positive-extremum))
(deftype ,positive-name ()
,(make-docstring above-zero positive-extremum :positive)
`(,',base-type ,',above-zero ,,positive-extremum))
(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)
(< ,zero n)))))))))
(frob fixnum integer)
(frob integer)
(frob rational)
(frob real)
(frob float)
(frob short-float)
(frob single-float)
(frob double-float)
(frob long-float))
(defun of-type (type)
"Returns a function of one argument, which returns true when its argument is
of TYPE."
(lambda (thing) (typep thing type)))
(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))
(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)
(declare (ignore sub))
(values nil ok))))))
(define-modify-macro coercef (type-spec) coerce
"Modify-macro for COERCE.")
|
