types.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
types.lisp (5864B)
---
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 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.")