types.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 bet… | |
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/doc… | |
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") (:posi… | |
33 (format nil "Type specifier denoting the ~(~A~) rang… | |
34 type | |
35 (if (equal range-beg ''*) inf (ensure-car ra… | |
36 (if (equal range-end ''*) inf (ensure-car ra… | |
37 (let* ((negative-name (make-subtype-name '#:negative-~a)) | |
38 (non-positive-name (make-subtype-name '#:non-positive-… | |
39 (non-negative-name (make-subtype-name '#:non-negative-… | |
40 (positive-name (make-subtype-name '#:positive-~a)) | |
41 (negative-p-name (make-predicate-name negative-nam… | |
42 (non-positive-p-name (make-predicate-name non-positive… | |
43 (non-negative-p-name (make-predicate-name non-negative… | |
44 (positive-p-name (make-predicate-name positive-nam… | |
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 'm… | |
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.0… | |
58 (short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0… | |
59 (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0… | |
60 (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0… | |
61 (long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0… | |
62 `(progn | |
63 (deftype ,negative-name () | |
64 ,(make-docstring negative-extremum below-zero :negativ… | |
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 :positiv… | |
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 argum… | |
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… | |
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.") |