1 |
|
;;; CMPTYPE Type information. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
|
24 |
|
;;; CL-TYPE is any valid type specification of Common Lisp. |
25 |
|
;;; |
26 |
|
;;; TYPE is a representation type used by KCL. TYPE is one of: |
27 |
|
;;; |
28 |
|
;;; T(BOOLEAN) |
29 |
|
;;; |
30 |
|
;;; FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT |
31 |
|
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) |
32 |
|
;;; (VECTOR SHORT-FLOAT) (VECTOR LONG-FLOAT) |
33 |
|
;;; (ARRAY T) (ARRAY STRING-CHAR) (ARRAY BIT) |
34 |
|
;;; (ARRAY FIXNUM) |
35 |
|
;;; (ARRAY SHORT-FLOAT) (ARRAY LONG-FLOAT) |
36 |
|
;;; UNKNOWN |
37 |
|
;;; |
38 |
|
;;; NIL |
39 |
|
;;; |
40 |
|
;;; |
41 |
|
;;; immediate-type: |
42 |
|
;;; FIXNUM int |
43 |
|
;;; CHARACTER char |
44 |
|
;;; SHORT-FLOAT float |
45 |
|
;;; LONG-FLOAT double |
46 |
|
|
47 |
|
|
48 |
|
;;; Check if THING is an object of the type TYPE. |
49 |
|
;;; Depends on the implementation of TYPE-OF. |
50 |
|
(defun object-type (thing) |
51 |
|
(let ((type (type-of thing))) |
52 |
|
(case type |
53 |
|
((fixnum short-float long-float) type) |
54 |
|
((string-char standard-char character) 'character) |
55 |
|
((string bit-vector) type) |
56 |
|
(vector (list 'vector (array-element-type thing))) |
57 |
|
(array (list 'array (array-element-type thing))) |
58 |
|
(t t)))) ; 'unknown ;; I can't see any use of this |
59 |
|
|
60 |
|
(defun type-filter (type) |
61 |
|
(case type |
62 |
|
((fixnum character short-float long-float) type) |
63 |
|
(single-float 'long-float) |
64 |
|
(boolean 'boolean) |
65 |
|
(double-float 'long-float) |
66 |
|
((simple-string string) 'string) |
67 |
|
((simple-bit-vector bit-vector) 'bit-vector) |
68 |
|
((nil t) t) |
69 |
|
(t (let ((type (si::normalize-type type)) element-type) |
70 |
|
(case (car type) |
71 |
|
((simple-array array) |
72 |
|
(cond ((or (endp (cdr type)) |
73 |
|
(not (setq element-type |
74 |
|
(cond ((eq '* (cadr type)) nil) |
75 |
|
((si::best-array-element-type |
76 |
|
(cadr type))) |
77 |
|
(t t))))) |
78 |
|
t) ; I don't know. |
79 |
|
((and (not (endp (cddr type))) |
80 |
|
(not (eq (caddr type) '*)) |
81 |
|
(or (eql (caddr type) 1) |
82 |
|
(and (consp (caddr type)) |
83 |
|
(= (length (caddr type)) 1)))) |
84 |
|
(case element-type |
85 |
|
(string-char 'string) |
86 |
|
(bit 'bit-vector) |
87 |
|
(t (list 'vector element-type)))) |
88 |
|
(t (list 'array element-type)))) |
89 |
|
(integer |
90 |
|
(if (si::sub-interval-p (cdr type) |
91 |
|
(list most-negative-fixnum |
92 |
|
most-positive-fixnum)) |
93 |
|
'fixnum |
94 |
|
'integer)) |
95 |
|
((short-float) 'short-float) |
96 |
|
((long-float double-float single-float) 'long-float) |
97 |
|
((stream) 'stream) |
98 |
|
(t (cond ((subtypep type 'fixnum) 'fixnum) |
99 |
|
((subtypep type 'integer) 'integer) |
100 |
|
((subtypep type 'character) 'character) |
101 |
|
((subtypep type 'short-float) 'short-float) |
102 |
|
((subtypep type 'long-float) 'long-float) |
103 |
|
((subtypep type '(vector t)) '(vector t)) |
104 |
|
((subtypep type 'string) 'string) |
105 |
|
((subtypep type 'bit-vector) 'bit-vector) |
106 |
|
((subtypep type '(vector fixnum)) '(vector fixnum)) |
107 |
|
((subtypep type '(vector short-float)) |
108 |
|
'(vector short-float)) |
109 |
|
((subtypep type '(vector long-float)) |
110 |
|
'(vector long-float)) |
111 |
|
((subtypep type '(array t)) '(array t)) |
112 |
|
((subtypep type '(array string-char)) |
113 |
|
'(array string-char)) |
114 |
|
((subtypep type '(array bit)) '(array bit)) |
115 |
|
((subtypep type '(array fixnum)) '(array fixnum)) |
116 |
|
((subtypep type '(array short-float)) |
117 |
|
'(array short-float)) |
118 |
|
((subtypep type '(array long-float)) |
119 |
|
'(array long-float)) |
120 |
|
((eq (car type) 'values) |
121 |
|
(if (null (cddr type)) |
122 |
|
(list 'values (type-filter (second type))) |
123 |
|
t)) |
124 |
|
((and (eq (car type) 'satisfies) |
125 |
|
(symbolp (second type)) |
126 |
|
(get (second type) 'type-filter))) |
127 |
|
(t t))) |
128 |
|
))))) |
129 |
|
|
130 |
|
|
131 |
|
|
132 |
|
(defun type-and (type1 type2) |
133 |
|
|
134 |
|
(cond ((equal type1 type2) type1) |
135 |
|
((eq type1 t) type2) |
136 |
|
((eq type1 '*) type2) |
137 |
|
((eq type1 'object) type2) |
138 |
|
((eq type2 'object) type1) |
139 |
|
((eq type2 t) type1) |
140 |
|
((eq type2 '*) type1) |
141 |
|
((and (consp type2) (eq (car type2) 'values)) |
142 |
|
(type-and type1 (second type2))) |
143 |
|
((consp type1) |
144 |
|
(case (car type1) |
145 |
|
(array |
146 |
|
(case (cadr type1) |
147 |
|
(string-char (if (eq type2 'string) type2 nil)) |
148 |
|
(bit (if (eq type2 'bit-vector) type2 nil)) |
149 |
|
(t (if (and (consp type2) |
150 |
|
(eq (car type2) 'vector) |
151 |
|
(eq (cadr type1) (cadr type2))) |
152 |
|
type2 nil)))) |
153 |
|
(vector |
154 |
|
(if (and (consp type2) (eq (car type2) 'array) |
155 |
|
(eq (cadr type1) (cadr type2))) |
156 |
|
type1 nil)) |
157 |
|
(values (type-and (second type1) type2)) |
158 |
|
(t nil))) |
159 |
|
(t (case type1 |
160 |
|
(string |
161 |
|
(if (and (consp type2) (eq (car type2) 'array) |
162 |
|
(eq (cadr type2) 'string-char)) |
163 |
|
type1 nil)) |
164 |
|
(bit-vector |
165 |
|
(if (and (consp type2) (eq (car type2) 'array) |
166 |
|
(eq (cadr type2) 'bit)) |
167 |
|
type1 nil)) |
168 |
|
(fixnum-float |
169 |
|
(if (member type2 '(fixnum float short-float long-float)) |
170 |
|
type2 nil)) |
171 |
|
(float |
172 |
|
(if (member type2 '(short-float long-float)) |
173 |
|
type2 nil)) |
174 |
|
((long-float short-float) |
175 |
|
(if (member type2 '(fixnum-float float)) |
176 |
|
type1 nil)) |
177 |
|
((signed-char unsigned-char signed-short) |
178 |
|
(if (eq type2 'fixnum) type1 nil)) |
179 |
|
((unsigned-short) |
180 |
|
(if (subtypep type1 type2) type1 nil)) |
181 |
|
(integer |
182 |
|
(case type2 |
183 |
|
(fixnum type2))) |
184 |
|
(fixnum |
185 |
|
(case type2 |
186 |
|
((integer fixnum-float) 'fixnum) |
187 |
|
((signed-char unsigned-char signed-short bit) |
188 |
|
type2) |
189 |
|
((unsigned-short) |
190 |
|
(if (subtypep type2 type1) type2 nil)))) |
191 |
|
)))) |
192 |
|
|
193 |
|
(defun type>= (type1 type2) |
194 |
|
(equal (type-and type1 type2) type2)) |
195 |
|
|
196 |
|
(defun reset-info-type (info) |
197 |
|
(if (info-type info) |
198 |
|
(let ((info1 (copy-info info))) |
199 |
|
(setf (info-type info1) t) |
200 |
|
info1) |
201 |
|
info)) |
202 |
|
|
203 |
|
(defun and-form-type (type form original-form &aux type1) |
204 |
|
(setq type1 (type-and type (info-type (cadr form)))) |
205 |
|
(when (null type1) |
206 |
|
(cmpwarn "The type of the form ~s is not ~s." original-form type)) |
207 |
|
(if (eq type1 (info-type (cadr form))) |
208 |
|
form |
209 |
|
(let ((info (copy-info (cadr form)))) |
210 |
|
(setf (info-type info) type1) |
211 |
|
(list* (car form) info (cddr form))))) |
212 |
|
|
213 |
|
(defun check-form-type (type form original-form) |
214 |
|
(when (null (type-and type (info-type (cadr form)))) |
215 |
|
(cmpwarn "The type of the form ~s is not ~s." original-form type))) |
216 |
|
|
217 |
|
(defun default-init (type) |
218 |
|
(case type |
219 |
|
(fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) |
220 |
|
(character (cmpwarn "The default value of NIL is not CHARACTER.")) |
221 |
|
(long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) |
222 |
|
(short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT.")) |
223 |
|
(integer (cmpwarn "The default value of NIL is not INTEGER")) |
224 |
|
|
225 |
|
) |
226 |
|
(c1nil)) |