24 |
|
|
25 |
(in-package 'system) |
(in-package 'system) |
26 |
|
|
27 |
(export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce) 'lisp) |
(export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce lisp::upgraded-array-element-type) 'lisp) |
28 |
|
|
29 |
(eval-when (compile) |
(eval-when (compile) |
30 |
(proclaim '(optimize (safety 2) (space 3))) |
(proclaim '(optimize (safety 2) (space 3))) |
53 |
'(deftype ,name ,lambda-list ,@body) |
'(deftype ,name ,lambda-list ,@body) |
54 |
'deftype-form) |
'deftype-form) |
55 |
(si:putprop ',name |
(si:putprop ',name |
56 |
#'(lambda ,lambda-list ,@body) |
(if (null ',lambda-list) |
57 |
|
(let ((tem (progn ,@body))) |
58 |
|
(lambda ,lambda-list tem)) |
59 |
|
(lambda ,lambda-list ,@body)) |
60 |
'deftype-definition) |
'deftype-definition) |
61 |
(si:putprop ',name |
(si:putprop ',name |
62 |
,(find-documentation body) |
,(find-documentation body) |
65 |
|
|
66 |
|
|
67 |
;;; Some DEFTYPE definitions. |
;;; Some DEFTYPE definitions. |
68 |
(deftype fixnum () |
;(deftype fixnum () |
69 |
`(integer ,most-negative-fixnum ,most-positive-fixnum)) |
; `(integer ,most-negative-fixnum ,most-positive-fixnum)) |
70 |
(deftype positive-fixnum () |
(deftype seqind () |
71 |
`(integer 0 ,most-positive-fixnum)) |
`(integer 0 ,array-dimension-limit)) |
72 |
(deftype fixnum () |
(deftype rnkind () |
73 |
`(integer ,most-negative-fixnum ,most-positive-fixnum)) |
`(integer 0 ,array-rank-limit)) |
74 |
|
;(deftype non-negative-fixnum () |
75 |
|
; `(integer 0 ,most-positive-fixnum)) |
76 |
|
;(deftype negative-fixnum () |
77 |
|
; `(integer ,most-negative-fixnum -1)) |
78 |
|
;(deftype fixnum () |
79 |
|
; `(integer ,most-negative-fixnum ,most-positive-fixnum)) |
80 |
(deftype bit () '(integer 0 1)) |
(deftype bit () '(integer 0 1)) |
81 |
(deftype mod (n) |
(deftype mod (n) |
82 |
`(integer 0 ,(1- n))) |
`(integer 0 ,(1- n))) |
83 |
(deftype positive-byte (&optional s) |
(deftype non-negative-byte (&optional s) |
84 |
(if (eq s '*) |
(if (eq s '*) |
85 |
`(integer * *) |
`(integer * *) |
86 |
`(integer 0 ,(1- (expt 2 (1- s)))))) |
`(integer 0 ,(1- (expt 2 (1- s)))))) |
87 |
|
(deftype negative-byte (&optional s) |
88 |
|
(if (eq s '*) |
89 |
|
`(integer * *) |
90 |
|
`(integer ,(- (expt 2 (1- s))) -1))) |
91 |
(deftype signed-byte (&optional s) |
(deftype signed-byte (&optional s) |
92 |
(if (eq s '*) |
(if (eq s '*) |
93 |
`(integer * *) |
`(integer * *) |
96 |
(if (eq s '*) |
(if (eq s '*) |
97 |
`(integer 0 *) |
`(integer 0 *) |
98 |
`(integer 0 ,(1- (expt 2 s))))) |
`(integer 0 ,(1- (expt 2 s))))) |
|
(deftype positive-char () `(positive-byte ,char-size)) |
|
|
(deftype signed-char ()`(signed-byte ,char-size)) |
|
|
(deftype unsigned-char ()`(unsigned-byte ,char-size)) |
|
|
(deftype positive-short () `(positive-byte ,short-size)) |
|
|
(deftype signed-short ()`(signed-byte ,short-size)) |
|
|
(deftype unsigned-short ()`(unsigned-byte ,short-size)) |
|
99 |
|
|
100 |
|
(deftype non-negative-char () `(non-negative-byte ,char-length)) |
101 |
|
(deftype negative-char () `(negative-byte ,char-length)) |
102 |
|
(deftype signed-char ()`(signed-byte ,char-length)) |
103 |
|
(deftype unsigned-char ()`(unsigned-byte ,char-length)) |
104 |
|
(deftype char ()`(signed-char)) |
105 |
|
|
106 |
|
(deftype non-negative-short () `(non-negative-byte ,short-length)) |
107 |
|
(deftype negative-short () `(negative-byte ,short-length)) |
108 |
|
(deftype signed-short ()`(signed-byte ,short-length)) |
109 |
|
(deftype unsigned-short ()`(unsigned-byte ,short-length)) |
110 |
|
(deftype short ()`(signed-short)) |
111 |
|
|
112 |
|
(deftype non-negative-fixnum () `(non-negative-byte ,fixnum-length)) |
113 |
|
(deftype negative-fixnum () `(negative-byte ,fixnum-length)) |
114 |
|
(deftype signed-fixnum ()`(signed-byte ,fixnum-length)) |
115 |
|
(deftype unsigned-fixnum ()`(unsigned-byte ,fixnum-length)) |
116 |
|
(deftype fixnum ()`(signed-fixnum)) |
117 |
|
|
118 |
|
(deftype non-negative-lfixnum () `(non-negative-byte ,lfixnum-length)) |
119 |
|
(deftype negative-lfixnum () `(negative-byte ,lfixnum-length)) |
120 |
|
(deftype signed-lfixnum ()`(signed-byte ,lfixnum-length)) |
121 |
|
(deftype unsigned-lfixnum ()`(unsigned-byte ,lfixnum-length)) |
122 |
|
(deftype lfixnum ()`(signed-lfixnum)) |
123 |
|
|
124 |
|
|
125 |
(deftype vector (&optional element-type size) |
(deftype vector (&optional element-type size) |
328 |
|
|
329 |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
330 |
;;; The type may not be normalized. |
;;; The type may not be normalized. |
331 |
|
|
332 |
|
;;FIXME -- get rid of this list. And those in subtypep. CM 20050106 |
333 |
(defun known-type-p (type) |
(defun known-type-p (type) |
334 |
(when (consp type) (setq type (car type))) |
(when (consp type) (setq type (car type))) |
335 |
(if (or (equal (string type) "ERROR") |
(if (or (equal (string type) "ERROR") |
336 |
(member type |
(member type |
337 |
'(t nil boolean null symbol keyword atom cons list sequence |
'(t nil boolean null symbol keyword atom cons list sequence |
338 |
positive-char negative-char signed-char unsigned-char |
non-negative-char negative-char signed-char unsigned-char |
339 |
positive-short negative-short signed-short unsigned-short |
non-negative-short negative-short signed-short unsigned-short |
340 |
positive-fixnum negative-fixnum |
non-negative-fixnum negative-fixnum |
341 |
number integer bignum rational ratio float method-combination |
number integer bignum rational ratio float method-combination |
342 |
short-float single-float double-float long-float complex |
short-float single-float double-float long-float complex |
343 |
character standard-char string-char real |
character standard-char string-char real |
370 |
((let ((a (car a))) (or (eq a '*) (eq a t))) |
((let ((a (car a))) (or (eq a '*) (eq a t))) |
371 |
(implicit-symbol (cdr a) b)))) |
(implicit-symbol (cdr a) b)))) |
372 |
|
|
373 |
|
(defun upgraded-array-element-type (type &optional environment) |
374 |
|
(declare (ignore environment)) |
375 |
|
(best-array-element-type type)) |
376 |
|
|
377 |
;;; SUBTYPEP predicate. |
;;; SUBTYPEP predicate. |
378 |
(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
379 |
(declare (ignore env)) |
(declare (ignore env)) |
704 |
(let* ((at1 (ty i1)) |
(let* ((at1 (ty i1)) |
705 |
(at2 (ty i2)) |
(at2 (ty i2)) |
706 |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
707 |
(unless (equal at1 at2) |
(unless (eq (upgraded-array-element-type at1) (upgraded-array-element-type at2)) |
708 |
(return-from subtypep (values nil t)))) |
(return-from subtypep (values nil t)))) |
709 |
(let ((ad1 (di i1)) |
(let ((ad1 (di i1)) |
710 |
(ad2 (di i2))) |
(ad2 (di i2))) |