Annotation of /sml/trunk/ckit/src/ast/type-util.sml

Parent Directory | Revision Log

---

Revision 597 - (view) (download)

1 :	dbm	597	(* Copyright (c) 1998 by Lucent Technologies *)
2 :
3 :			structure TypeUtil : TYPE_UTIL =
4 :			struct
5 :
6 :			structure S = Symbol
7 :			structure Pid = Pid
8 :			structure Tid = Tid
9 :			structure B = Bindings
10 :			structure TypeCheckControl = Config.TypeCheckControl
11 :
12 :			exception TypeError of Ast.ctype
13 :
14 :			(* some parameters used here, but passed in that should be lifted out of here *)
15 :			fun warning s = (print "warning "; print s; print "\n")
16 :
17 :			fun internalError s = (print "internal error "; print s; print "\n")
18 :
19 :			val don't_convert_SHORT_to_INT = TypeCheckControl.don't_convert_SHORT_to_INT
20 :			(* In ANSI C, usual unary converstion converts
21 :			SHORT to INT; for DSP code, we want to
22 :			keep SHORT as SHORT.
23 :			Default: true for ANSI C behavior *)
24 :
25 :			val don't_convert_DOUBLE_in_usual_unary_cnv = TypeCheckControl.don't_convert_DOUBLE_in_usual_unary_cnv
26 :			(* In ANSI, FLOAT is not converted to DOUBLE during
27 :			usual unary converstion; in old style compilers
28 :			FLOAT *is* converted to DOUBLE.
29 :			Default: true for ANSI behavior *)
30 :
31 :			val enumeration_incompatibility = TypeCheckControl.enumeration_incompatibility
32 :			(* ANSI says that different enumerations are incomptible
33 :			(although all are compatible with int);
34 :			older style compilers say that different enumerations
35 :			are compatible.
36 :			Default: true for ANSI behavior *)
37 :
38 :			val pointer_compatibility_quals = TypeCheckControl.pointer_compatibility_quals
39 :			(* ANSI says that pointers to differently qualified types
40 :			are different; some compilers vary.
41 :			Default: true for ANSI behavior *)
42 :
43 :			val stdInt = Ast.Numeric(Ast.NONSATURATE, Ast.WHOLENUM, Ast.SIGNED, Ast.INT, Ast.SIGNASSUMED)
44 :
45 :			fun ctToString tidtab =
46 :			PPLib.ppToString (PPAst.ppCtype () tidtab)
47 :			(* pid table actually not needed to print out a ct, but it is
48 :			a parameter passed to ppCtype, so just fudge one to make types work.
49 :			This is ugly dpo?
50 :			*)
51 :
52 :			fun reduceTypedef (tidtab: Tables.tidtab) ty =
53 :			case ty
54 :			of Ast.TypeRef tid =>
55 :			(case Tidtab.find (tidtab,tid)
56 :			of SOME{ntype=SOME(B.Typedef (_,ty)),...} => reduceTypedef tidtab ty
57 :			| _ => ( internalError "poorly formed type table (unresolved type id),assuming Void"
58 :			; Ast.Void
59 :			)
60 :
61 :			)
62 :			| ty => ty
63 :
64 :			fun getCoreType tidtab ty =
65 :			(* derefs typedefs and and removes qualifiers *)
66 :			case ty
67 :			of Ast.TypeRef tid => getCoreType tidtab (reduceTypedef tidtab ty)
68 :			| Ast.Qual (_,ty) => getCoreType tidtab ty
69 :			| ty => ty
70 :
71 :			fun checkQuals tidtab ty =
72 :			let fun check ty =
73 :			(case ty
74 :			of Ast.TypeRef tid => check (reduceTypedef tidtab ty)
75 :			| Ast.Qual (q,ty) =>
76 :			let val {volatile, const, cerr, verr} = check ty
77 :			in
78 :			case q of
79 :			Ast.CONST => {volatile=volatile, const=true, verr=verr, cerr=const}
80 :			| Ast.VOLATILE => {volatile=true, const=const, cerr=cerr, verr=volatile}
81 :			end
82 :			| ty => {volatile=false, const=false, verr=false, cerr=false})
83 :			val res = check ty
84 :			in
85 :			{redundantConst = #cerr res,
86 :			redundantVolatile = #verr res}
87 :			end
88 :
89 :			fun getQuals tidtab ty =
90 :			(* collects qualifiers *)
91 :			case ty
92 :			of Ast.TypeRef tid => getQuals tidtab (reduceTypedef tidtab ty)
93 :			| Ast.Qual (q,ty) =>
94 :			let val {volatile, const, ty} = getQuals tidtab ty
95 :			in
96 :			case q of
97 :			Ast.CONST => {volatile=volatile, const=true, ty=ty}
98 :			| Ast.VOLATILE => {volatile=true, const=const, ty=ty}
99 :			end
100 :			| ty => {volatile=false, const=false, ty=ty}
101 :
102 :			(*
103 :			fun hasKnownStorageSize tidtab {ty, withInitializer} =
104 :			(* withInitializer=true: does ty have known storage size when an initializer is present (see array case)
105 :			withInitializer=false: does ty have known storage size, period. *)
106 :			case ty of
107 :			Ast.Void => false
108 :			| Ast.Qual(_, ty) => hasKnownStorageSize tidtab ty
109 :			| Ast.Numeric _ => true
110 :			| Ast.Array(SOME _, ty) => hasKnownStorageSize tidtab ty
111 :			| Ast.Array(NONE, _) => withInitializer
112 :			| Ast.Pointer _ => true
113 :			| Ast.Function _ => true
114 :			| Ast.EnumRef tid => true
115 :			| Ast.AggrRef tid =>
116 :			(case Tidtab.find (tidtab,tid)
117 :			of SOME(_,SOME(Ast.Aggr (_,_,fields)),_) =>
118 :			List.foldl
119 :			(fn ((ty, _, _), b) => b andalso (hasKnownStorageSize tidtab ty))
120 :			true fields
121 :			| _ => false)
122 :			| Ast.TypeRef tid => hasKnownStorageSize tidtab (reduceTypedef tidtab ty)
123 :			| Ast.Ellipses => false
124 :			*)
125 :
126 :			fun hasKnownStorageSize (tidtab: Tables.tidtab) ty =
127 :			case ty
128 :			of Ast.Void => false
129 :			| Ast.Qual(_, ty) => hasKnownStorageSize tidtab ty
130 :			| Ast.Numeric _ => true
131 :			| Ast.Array(SOME _, ty) => hasKnownStorageSize tidtab ty
132 :			| Ast.Array(NONE, _) => false
133 :			| Ast.Pointer _ => true
134 :			| Ast.Function _ => true
135 :			| Ast.EnumRef tid =>
136 :			(case Tidtab.find (tidtab,tid)
137 :			of SOME{ntype=SOME _, ...} => true
138 :			| _ =>
139 :			if TypeCheckControl.partial_enums_have_unknown_size then false
140 :			else true)
141 :			| Ast.StructRef tid =>
142 :			(case Tidtab.find (tidtab,tid)
143 :			of SOME{ntype=SOME(B.Struct (_,fields)),...} =>
144 :			List.all
145 :			(fn (ty, _, _) => (hasKnownStorageSize tidtab ty))
146 :			fields
147 :			| _ => false)
148 :			| Ast.UnionRef tid =>
149 :			(case Tidtab.find (tidtab,tid)
150 :			of SOME{ntype=SOME(B.Union (_,fields)),...} =>
151 :			List.all
152 :			(fn (ty, _) => (hasKnownStorageSize tidtab ty))
153 :			fields
154 :			| _ => false)
155 :			| Ast.TypeRef tid => hasKnownStorageSize tidtab (reduceTypedef tidtab ty)
156 :			| Ast.Ellipses => false
157 :			| Ast.Error => false
158 :
159 :			(*
160 :			fun fixArrayType tidtab {ty, n} =
161 :			case ty of
162 :			Ast.Void => {err=(n<=1), ty}
163 :			| Ast.Qual(_, ty) => fixArrayType tidtab {ty=ty, n=n}
164 :			| Ast.Numeric _ => {err=(n<=1), ty}
165 :			| Ast.Array(SOME n', ty) => {err=(n<=n'), ty}
166 :			| Ast.Array(NONE, ty) => {err=true, Ast.Array(SOME n, ty})
167 :			| Ast.Pointer _ => {err=(n<=1), ty}
168 :			| Ast.Function _ => {err=(n<=1), ty}
169 :			| Ast.EnumRef tid => {err=(n<=1), ty}
170 :			| Ast.AggrRef tid => {err=(n<=1), ty}
171 :			| Ast.TypeRef tid => fixArrayType tidtab {ty=reduceTypedef tidtab ty, n=n}
172 :			| Ast.Ellipses => {err=false, ty}
173 :			*)
174 :
175 :			fun isConst tidtab ty = #const(getQuals tidtab ty)
176 :
177 :			fun isPointer tidtab ty =
178 :			case ty
179 :			of Ast.Qual (_,ty) => isPointer tidtab ty
180 :			| Ast.Array _ => true
181 :			| Ast.Pointer _ => true
182 :			| Ast.Function _ => true
183 :			| Ast.TypeRef _ => isPointer tidtab (reduceTypedef tidtab ty)
184 :			| _ => false
185 :
186 :			fun isIntegral tidtab ty =
187 :			case ty
188 :			of Ast.Qual (_,ty) => isIntegral tidtab ty
189 :			| Ast.Array _ => false
190 :			| Ast.Pointer _ => false
191 :			| Ast.Function _ => false
192 :			| Ast.Numeric(sat, frac, sign, Ast.CHAR, _) => true
193 :			| Ast.Numeric(sat, frac, sign, Ast.SHORT, _) => true
194 :			| Ast.Numeric(sat, frac, sign, Ast.INT, _) => true
195 :			| Ast.Numeric(sat, frac, sign, Ast.LONG, _) => true
196 :			| Ast.Numeric(sat, frac, sign, Ast.LONGLONG, _) => true
197 :			| Ast.Numeric(sat, frac, sign, Ast.FLOAT, _) => false
198 :			| Ast.Numeric(sat, frac, sign, Ast.DOUBLE, _) => false
199 :			| Ast.Numeric(sat, frac, sign, Ast.LONGDOUBLE, _) => false
200 :			| Ast.EnumRef _ => true
201 :			| Ast.TypeRef _ => isIntegral tidtab (reduceTypedef tidtab ty)
202 :			| _ => false
203 :
204 :			fun isArray tidtab ty =
205 :			case ty
206 :			of Ast.Qual (_,ty) => isArray tidtab ty
207 :			| Ast.Array _ => true
208 :			| Ast.TypeRef _ => isArray tidtab (reduceTypedef tidtab ty)
209 :			| _ => false
210 :
211 :			fun isNumberOrPointer tidtab ty =
212 :			case ty
213 :			of Ast.Qual (_,ty) => isNumberOrPointer tidtab ty
214 :			| Ast.Array _ => true
215 :			| Ast.Pointer _ => true
216 :			| Ast.Function _ => true
217 :			| Ast.Numeric _ => true
218 :			| Ast.EnumRef _ => true
219 :			| Ast.TypeRef _ => isNumberOrPointer tidtab (reduceTypedef tidtab ty)
220 :			| _ => false
221 :
222 :			fun isNumber tidtab ty =
223 :			case ty
224 :			of Ast.Qual (_,ty) => isNumber tidtab ty
225 :			| Ast.Array _ => false
226 :			| Ast.Pointer _ => false
227 :			| Ast.Function _ => false
228 :			| Ast.Numeric _ => true
229 :			| Ast.EnumRef _ => true
230 :			| Ast.TypeRef _ => isNumber tidtab (reduceTypedef tidtab ty)
231 :			| _ => false
232 :
233 :			fun deref tidtab ty =
234 :			case ty
235 :			of Ast.Qual (_,ty) => deref tidtab ty
236 :			| Ast.Array (_,ty) => SOME ty
237 :			| Ast.Pointer ty => SOME ty
238 :			| Ast.Function _ => SOME ty
239 :			| Ast.TypeRef _ => deref tidtab (reduceTypedef tidtab ty)
240 :			| _ => NONE
241 :
242 :			fun getFunction tidtab ty =
243 :			let fun getF ty {deref} =
244 :			case ty
245 :			of Ast.Qual (_,ty) => getF ty {deref=deref}
246 :			| Ast.Pointer ty => if deref then NONE else getF ty {deref=true}
247 :			(* allow one level of dereferencing of function pointers
248 :			see H & S p 147: "an expression of type `pointer to function' can be used in a
249 :			function call without an explicit dereferencing" *)
250 :			| Ast.Function (retTy,argTys) => SOME(retTy,argTys)
251 :			| Ast.TypeRef _ => getF (reduceTypedef tidtab ty) {deref=deref}
252 :			| _ => NONE
253 :			in
254 :			getF ty {deref=false}
255 :			end
256 :
257 :			fun isFunction tidtab ty = (* returns true of ty is a function; excludes fn pointer case *)
258 :			case reduceTypedef tidtab ty of (* might have prototype fn def using typedef?? *)
259 :			Ast.Function _ => true
260 :			| _ => false
261 :
262 :			fun isFunctionPrototype tidtab ty =
263 :			case getFunction tidtab ty of
264 :			NONE => false
265 :			| SOME(_, nil) => false
266 :			| SOME(_, _ :: _) => true
267 :
268 :			fun isNonPointerFunction tidtab ty =
269 :			case ty
270 :			of Ast.Qual (_,ty) => isNonPointerFunction tidtab ty
271 :			| Ast.TypeRef _ => isNonPointerFunction tidtab (reduceTypedef tidtab ty)
272 :			| Ast.Function _ => true
273 :			| _ => false
274 :
275 :			fun isStructOrUnion tidtab ty =
276 :			case reduceTypedef tidtab ty
277 :			of Ast.Qual (_,ty) => isStructOrUnion tidtab ty
278 :			| (Ast.StructRef tid | Ast.UnionRef tid) => SOME tid
279 :			| _ => NONE
280 :
281 :			fun isEnum tidtab (ty,member as {uid,kind=Ast.ENUMmem _,...}: Ast.member) =
282 :			(case reduceTypedef tidtab ty
283 :			of Ast.Qual (_,ty) => isEnum tidtab (ty,member)
284 :			| Ast.EnumRef tid =>
285 :			(case Tidtab.find (tidtab,tid)
286 :			of SOME {ntype=SOME (B.Enum (_,memberIntList)),...} =>
287 :			let fun pred ({uid=uid',...}: Ast.member,_) =
288 :			Pid.equal (uid',uid)
289 :			in List.exists pred memberIntList end
290 :			| SOME {ntype=NONE,...} =>
291 :			(warning
292 :			"Enum type used but not declared, assuming member is not an EnumId";
293 :			false)
294 :			| SOME {ntype=SOME _,...} =>
295 :			(internalError
296 :			("poorly formed type table: expected enumerated type for "
297 :			^ (Tid.toString tid));
298 :			false)
299 :			| NONE =>
300 :			(internalError
301 :			("poorly formed type table: expected enumerated type for "
302 :			^ (Tid.toString tid));
303 :			false))
304 :			| _ => false)
305 :			| isEnum tidtab (ty,member) =
306 :			(internalError "isEnum applied to struct or union member";
307 :			false)
308 :
309 :			fun lookupEnum tidtab (ty,member as {uid,...}: Ast.member) =
310 :			case reduceTypedef tidtab ty
311 :			of Ast.Qual (_,ty) => lookupEnum tidtab (ty,member)
312 :			| Ast.EnumRef tid =>
313 :			(case Tidtab.find (tidtab,tid)
314 :			of SOME{ntype=SOME(B.Enum(_,memberIntList)),...} =>
315 :			let fun pred ({uid=uid',...}: Ast.member,_) =
316 :			Pid.equal(uid', uid)
317 :			in case List.find pred memberIntList
318 :			of SOME (_,i) => SOME i
319 :			| NONE => NONE
320 :			end
321 :			| _ => NONE)
322 :			| _ => NONE
323 :
324 :			(* Haberson/Steele "C Reference Manual", 4th Ed, section 5.11.1 p152 *)
325 :			fun equalType tidtab (ty1,ty2) =
326 :			let open Ast
327 :			fun eq (ty1,ty2) =
328 :			case (ty1,ty2)
329 :			of (Void, Void) => true
330 :			| (Qual(q1, ct1), Qual(q2, ct2)) =>
331 :			(q1 = q2) andalso eq (ct1, ct2)
332 :			| (Numeric(sat1, frac1, sign1, intKnd1, signednessTag1),
333 :			Numeric(sat2, frac2, sign2, intKnd2, signednessTag2)) =>
334 :			sat1 = sat2 andalso frac1 = frac2 andalso
335 :			sign1 = sign2 andalso intKnd1 = intKnd2
336 :			(* note: don't require signednessTags to be the same *)
337 :			| (Array(SOME(i1, _), ct1), Array(SOME(i2,_), ct2)) => (i1=i2) andalso eq (ct1, ct2)
338 :			| (Array(NONE, ct1), Array(NONE, ct2)) => eq (ct1, ct2)
339 :			| (Array _, Array _) => false
340 :			| (Pointer ct1, Pointer ct2) => eq (ct1, ct2)
341 :			| (Function(ct1, ctl1), Function(ct2, ctl2)) =>
342 :			eq (ct1, ct2) andalso eql (ctl1, ctl2)
343 :			| (EnumRef tid1, EnumRef tid2) => Tid.equal (tid1, tid2)
344 :			| (UnionRef tid1, UnionRef tid2) => Tid.equal (tid1, tid2)
345 :			| (StructRef tid1, StructRef tid2) => Tid.equal (tid1, tid2)
346 :			| (TypeRef _, _) => eq (reduceTypedef tidtab ty1, ty2)
347 :			| (_, TypeRef _) => eq (ty1, reduceTypedef tidtab ty2)
348 :			| _ => false
349 :			and eql ([],[]) = true
350 :			| eql (ty1::tyl1,ty2::tyl2) = eq (ty1,ty2) andalso eql (tyl1,tyl2)
351 :			| eql _ = false
352 :			in eq (ty1,ty2) end
353 :
354 :			(* implements "ISO C conversion" column of table 6-4 in Haberson/Steele, p175
355 :			"C Reference Manual", 4th Ed *)
356 :
357 :			fun usualUnaryCnv tidtab tp =
358 :			let val tp = getCoreType tidtab tp
359 :			in case tp
360 :			of Ast.Numeric (sat, frac, _, Ast.CHAR, _) =>
361 :			Ast.Numeric (sat, frac, Ast.SIGNED, if don't_convert_SHORT_to_INT then Ast.SHORT else Ast.INT, Ast.SIGNASSUMED)
362 :			| Ast.Numeric (sat, frac, _, Ast.SHORT,_) =>
363 :			Ast.Numeric (sat, frac, Ast.SIGNED, if don't_convert_SHORT_to_INT then Ast.SHORT else Ast.INT, Ast.SIGNASSUMED)
364 :			(* for dsp work, want to keep short as short *)
365 :			| ty as (Ast.Numeric (sat, frac, sign, Ast.FLOAT, d)) =>
366 :			if don't_convert_DOUBLE_in_usual_unary_cnv then ty else Ast.Numeric (sat, frac, sign, Ast.DOUBLE, d)
367 :			| Ast.Array (_, arrayTp) => if (Config.DFLAG) then tp else Ast.Pointer arrayTp
368 :			| Ast.Function x => Ast.Pointer tp (* this code is now not used: it is overridden by the stronger condition that
369 :			all expressions of Function type are converted to Pointer(Function),
370 :			(except for & and sizeof) *)
371 :			| Ast.EnumRef _ => stdInt
372 :			(* Not explicit in table 6-4, but seems to be implicitly assumed -- e.g. see compatiblity *)
373 :			| _ => tp
374 :			end
375 :
376 :			(* implements section 6.3.5 of H&S, p177. *)
377 :			fun functionArgConv tidtab tp =
378 :			case getCoreType tidtab tp
379 :			of
380 :			(Ast.Numeric (sat, frac, sign, Ast.FLOAT, d)) =>
381 :			Ast.Numeric (sat, frac, sign, Ast.DOUBLE, d)
382 :			| _ => usualUnaryCnv tidtab tp
383 :
384 :			fun combineSat (Ast.SATURATE, Ast.SATURATE) = Ast.SATURATE
385 :			| combineSat _ = Ast.NONSATURATE
386 :
387 :			fun combineFrac (Ast.FRACTIONAL, _) = Ast.FRACTIONAL
388 :			| combineFrac (_, Ast.FRACTIONAL) = Ast.FRACTIONAL
389 :			| combineFrac _ = Ast.WHOLENUM
390 :
391 :			(* follows "ISO C conversion" column of table 6-5 in Haberson/Steele, p176
392 :			"C Reference Manual", 4th Ed *)
393 :			fun usualBinaryCnv tidtab (tp1,tp2) =
394 :			case ( usualUnaryCnv tidtab (getCoreType tidtab tp1)
395 :			, usualUnaryCnv tidtab (getCoreType tidtab tp2)
396 :			)
397 :			of ( Ast.Numeric(sat1, frac1, sign1, int1, d1)
398 :			, Ast.Numeric(sat2, frac2, sign2, int2, d2)
399 :			) =>
400 :			(* removes CHAR, and (maybe) SHORT *)
401 :			let val (sign', int') =
402 :			case ((sign1, int1), (sign2, int2))
403 :			of ((_, Ast.LONGDOUBLE), _) => (Ast.SIGNED, Ast.LONGDOUBLE)
404 :			| (_, (_, Ast.LONGDOUBLE)) => (Ast.SIGNED, Ast.LONGDOUBLE)
405 :			| ((_, Ast.DOUBLE), _) => (Ast.SIGNED, Ast.DOUBLE)
406 :			| (_, (_, Ast.DOUBLE)) => (Ast.SIGNED, Ast.DOUBLE)
407 :			| ((_, Ast.FLOAT), _) => (Ast.SIGNED, Ast.FLOAT)
408 :			| (_, (_, Ast.FLOAT)) => (Ast.SIGNED, Ast.FLOAT)
409 :
410 :			(* we've removed: LONGDOUBLE, DOUBLE, FLOAT, CHAR and (maybe) SHORT *)
411 :			(* this leaves: INT, LONG, LONGLONG and (possibly) SHORT *)
412 :			| (x1, x2) =>
413 :			let
414 :			val int' =
415 :			case (int1, int2)
416 :			of (Ast.LONGLONG, _) => Ast.LONGLONG
417 :			| (_, Ast.LONGLONG) => Ast.LONGLONG
418 :			| (Ast.LONG, _) => Ast.LONG
419 :			| (_, Ast.LONG) => Ast.LONG
420 :			| (Ast.INT, _) => Ast.INT
421 :			| (_, Ast.INT) => Ast.INT
422 :			| (Ast.SHORT, _) => Ast.SHORT
423 :			| (_, Ast.SHORT) => Ast.SHORT
424 :			| _ => int1 (* should be nothing left *)
425 :			val sign' =
426 :			case (sign1, sign2)
427 :			of (Ast.UNSIGNED, _) => Ast.UNSIGNED
428 :			| (_, Ast.UNSIGNED) => Ast.UNSIGNED
429 :			| _ => Ast.SIGNED
430 :			in (sign', int') end
431 :			in
432 :			SOME ( Ast.Numeric(combineSat(sat1, sat2)
433 :			, combineFrac(frac1, frac2), sign', int', Ast.SIGNASSUMED)
434 :			)
435 :			end
436 :			| (tp1', tp2') =>
437 :			(print "Warning: unexpected call of usualBinaryCnv on non-Numeric types\n";
438 :			if equalType tidtab (tp1',tp2')
439 :			then SOME tp1'
440 :			else NONE)
441 :
442 :			(* Many compilers consider function args to be compatible when they
443 :			can be converted to pointers of the same type *)
444 :			fun preArgConv tidtab ty =
445 :			(case reduceTypedef tidtab ty of
446 :			Ast.Array (_, arrayTp) => Ast.Pointer arrayTp
447 :			| Ast.Function x => Ast.Pointer ty
448 :			| Ast.Qual(q, ty) => Ast.Qual(q, preArgConv tidtab ty)
449 :			| _ => ty)
450 :
451 :			(* Used to convert function args of type Function(...) to Pointer(Function(...)) *)
452 :			fun cnvFunctionToPointer2Function tidtab ty =
453 :			(case getCoreType tidtab ty of
454 :			(coreType as (Ast.Function _)) => Ast.Pointer(coreType)
455 :			| _ => ty)
456 :
457 :			(* section 5.11, pp151-155, in Haberson/Steele "C Reference Manual", 4th Ed *)
458 :			fun composite tidtab (ty1,ty2) =
459 :			let
460 :			open Ast
461 :			fun enumCompose (tid, ty) =
462 :			(case ty of
463 :			EnumRef tid2 =>
464 :			if enumeration_incompatibility then
465 :			if Tid.equal(tid, tid2) then SOME ty else NONE
466 :			else
467 :			SOME ty (* old style: all enums are compatible *)
468 :
469 :			| Numeric(NONSATURATE, WHOLENUM, SIGNED, INT, d) => SOME(Numeric(NONSATURATE, WHOLENUM, SIGNED, INT, d))
470 :			(* enumeration types are always compatible with the underlying implementation type,
471 :			assume in this frontend to the int *)
472 :			| _ => NONE)
473 :
474 :			fun compose (ty1,ty2) =
475 :			let val ty1 = if pointer_compatibility_quals then ty1 else getCoreType tidtab ty1
476 :			val ty2 = if pointer_compatibility_quals then ty2 else getCoreType tidtab ty2
477 :			fun em1() = ("Prototype " ^ (ctToString tidtab ty1) ^
478 :			" and non-prototype " ^ (ctToString tidtab ty2) ^
479 :			" are not compatible because parameter is not compatible with the" ^
480 :			" type after applying default argument promotion.")
481 :			fun em2() = ("Prototype " ^ (ctToString tidtab ty2) ^
482 :			" and non-prototype " ^ (ctToString tidtab ty1) ^
483 :			" are not compatible because parameter is not compatible with the" ^
484 :			" type after applying default argument promotion.")
485 :			in
486 :			case (ty1,ty2)
487 :			of
488 :			(Void, Void) => (SOME(Void), nil)
489 :			| (TypeRef _, _) => compose (reduceTypedef tidtab ty1, ty2)
490 :			| (_, TypeRef _) => compose (ty1, reduceTypedef tidtab ty2)
491 :			| (EnumRef tid1, _) => (enumCompose(tid1, ty2), nil)
492 :			| (_, EnumRef tid2) => (enumCompose(tid2, ty1), nil)
493 :			| (Array(io1, ct1), Array(io2, ct2)) =>
494 :			(case (compose(ct1, ct2), io1, io2) of
495 :			((SOME ct, eml), NONE, NONE) => (SOME(Array(NONE, ct)), eml)
496 :			| ((SOME ct, eml), SOME opt1, NONE) => (SOME(Array(SOME opt1, ct)), eml)
497 :			| ((SOME ct, eml), NONE, SOME opt2) => (SOME(Array(SOME opt2, ct)), eml)
498 :			| ((SOME ct, eml), SOME(i1, expr1), SOME(i2, _)) =>
499 :			(* potential source-to-source problem: what if i1=i2, but expr1 and expr2 are diff? *)
500 :			if (i1 = i2) then (SOME(Array(SOME(i1, expr1), ct)),
501 :			eml)
502 :			else (NONE, "Arrays have different lengths." :: eml)
503 :			| ((NONE,eml),_, _) => (NONE,eml))
504 :			| (Function(ct1, nil), Function(ct2, nil)) => (* both non-prototypes *)
505 :			(case compose (ct1, ct2) of
506 :			(NONE, eml) => (NONE, eml)
507 :			| (SOME ct, eml) => (SOME(Function(ct, nil)), eml))
508 :			| (Function(ct1, [Void]), Function(ct2, nil)) => (* first is Void-arg-prototype *)
509 :			(case compose (ct1, ct2) of
510 :			(NONE, eml) => (NONE, eml)
511 :			| (SOME ct, eml) => (SOME(Function(ct, [Void])), eml))
512 :			| (Function(ct1, nil), Function(ct2, [Void])) => (* second is Void-arg-prototype *)
513 :			(case compose (ct1, ct2) of
514 :			(NONE, eml) => (NONE, eml)
515 :			| (SOME ct, eml) => (SOME(Function(ct, [Void])), eml))
516 :			| (Function(ct1, ctl1), Function(ct2, nil)) => (* first is prototype *)
517 :			(case (compose(ct1, ct2), checkArgs ctl1) of
518 :			((SOME ct,eml), fl) => (SOME(Function(ct, ctl1)), if fl then eml else (em1()) :: eml)
519 :			| ((NONE, eml), fl) => (NONE, if fl then eml else (em1()) :: eml))
520 :			| (Function(ct1, nil), Function(ct2, ctl2)) => (* second is prototype *)
521 :			(case (compose(ct1, ct2), checkArgs ctl2) of
522 :			((SOME ct, eml), fl) => (SOME(Function(ct, ctl2)), if fl then eml else (em2()) :: eml)
523 :			| ((NONE, eml), fl) => (NONE, if fl then eml else (em2()) :: eml))
524 :			| (Function(ct1, ctl1), Function(ct2, ctl2)) => (* both are prototypes *)
525 :			(case (compose (ct1, ct2), composel (ctl1, ctl2)) of (* composel: deals with ellipses *)
526 :			((SOME ct, eml1), (SOME ctl, eml2)) => (SOME(Function(ct, ctl)), eml1 @ eml2)
527 :			| ((_, eml1), (_, eml2)) => (NONE, eml1 @ eml2))
528 :			| (ct1 as Qual _, ct2 as Qual _) =>
529 :			let val {volatile, const, ty=ct} = getQuals tidtab ct1
530 :			val {volatile=volatile', const=const', ty=ct'} = getQuals tidtab ct2
531 :			in case compose (ct, ct') of
532 :			(NONE, eml) => (NONE, eml)
533 :			| (SOME ct, eml) => let val ct = if volatile then Qual(VOLATILE, ct) else ct
534 :			val ct = if const then Qual(CONST, ct) else ct
535 :			in
536 :			(SOME ct, eml)
537 :			end
538 :			end
539 :			| (Numeric x, Numeric y) => if x = y then (SOME ty1, nil) else (NONE, nil)
540 :			| (Pointer ct1, Pointer ct2) => (case compose (ct1, ct2) of
541 :			(SOME ct, eml) => (SOME(Pointer ct), eml)
542 :			| (NONE, eml) => (NONE, eml))
543 :			| ((StructRef tid1, StructRef tid2) | (UnionRef tid1, UnionRef tid2)) =>
544 :			if Tid.equal (tid1, tid2) then (SOME ty1, nil) else (NONE, nil)
545 :			| _ => (NONE, nil)
546 :			end
547 :			and checkArgs (Ellipses :: _) = true
548 :			| checkArgs (ct :: ctl) = (case compose(ct, functionArgConv tidtab ct) of
549 :			(NONE, _) => false
550 :			| (SOME _, _) => checkArgs ctl
551 :			(* H & S, p 154, midpage:
552 :			each parameter type T must be compatible with the type
553 :			resulting from applying the usual unary conversions to T.
554 :			Correction: usual unary cnv except that float always
555 :			converted to unary (c.f. ISO conversion)
556 :			*)
557 :			)
558 :			| checkArgs nil = true
559 :			and composel ([],[]) = (SOME nil, nil)
560 :			| composel ([Ast.Ellipses], [Ast.Ellipses]) = (SOME([Ast.Ellipses]), nil)
561 :			| composel ([Ast.Ellipses], _) = (NONE, ["Use of ellipses does not match."])
562 :			| composel (_, [Ast.Ellipses]) = (NONE, ["Use of ellipses does not match."])
563 :			| composel (ty1::tyl1,ty2::tyl2) =
564 :			(case (compose (ty1,ty2), composel (tyl1,tyl2)) of
565 :			((SOME ty, eml1), (SOME tyl, eml2)) => (SOME(ty :: tyl), eml1@eml2)
566 :			| ((_, eml1), (_, eml2)) => (NONE, eml1@eml2))
567 :			| composel _ = (NONE, ["Function types have different numbers of arguments."])
568 :			in compose (ty1,ty2) end
569 :
570 :			fun compatible tidtab (ty1,ty2) =
571 :			(case composite tidtab (ty1,ty2) of
572 :			(SOME _, _) => true
573 :			| (NONE, _) => false)
574 :
575 :			fun isAssignable tidtab {lhs, rhs, rhsExpr0} =
576 :			(* From H&S p 174, table 6-3 (but also see Table 7-7, p221)
577 :			Note 1: This function just checks that the implicit assignment conversion is allowable.
578 :			- it does not check that lhs is assignable.
579 :			Note 2: The usualUnaryCnv conversion on rhs is not explicit in H & S,
580 :			but seems implied?
581 :			(otherwise can't typecheck: int i[4], *j = i)
582 :			Note 3: The definition below structure to correspond to table 6-3, but because of the
583 :			redundancy in this definition, we have reorganized order of some lines
584 :			Note 4: The EnumRef case is not explicit in Table 6-3,
585 :			but seems implied by compatibility (and is needed).
586 :			*)
587 :			(case (getCoreType tidtab lhs, usualUnaryCnv tidtab rhs, rhsExpr0) of
588 :			(* Note: usualUnary eliminates: Array, Function and Enum *)
589 :
590 :			(*1*) (Ast.Numeric _, Ast.Numeric _, _) => true
591 :
592 :			(*2a*) | (ty1 as Ast.StructRef _, ty2 as Ast.StructRef _, _) => compatible tidtab (ty1, ty2)
593 :			(*2b*) | (ty1 as Ast.UnionRef _, ty2 as Ast.UnionRef _, _) => compatible tidtab (ty1, ty2)
594 :
595 :			(*3a*) | (Ast.Pointer Ast.Void, _, true) => true
596 :			(*3c*) | (Ast.Pointer Ast.Void, Ast.Pointer Ast.Void, _) => true
597 :			(*3b*) | (Ast.Pointer Ast.Void, Ast.Pointer _, _) => true
598 :
599 :
600 :			(*5a*) | (Ast.Pointer (Ast.Function _), _, true) => true
601 :			(*5b*) | (Ast.Pointer (ty1 as Ast.Function _), Ast.Pointer (ty2 as Ast.Function _), _)
602 :			=> compatible tidtab (ty1,ty2)
603 :
604 :			(*4a*) | (Ast.Pointer ty1, _, true) => true
605 :			(*4c*) | (Ast.Pointer _, Ast.Pointer Ast.Void, _) => true
606 :			(*4b*) | (Ast.Pointer ty1, Ast.Pointer ty2, _) =>
607 :			let
608 :			val ty1' = getCoreType tidtab ty1
609 :			val ty2' = getCoreType tidtab ty2
610 :			val {volatile=vol1, const=const1, ...} = getQuals tidtab ty1
611 :			val {volatile=vol2, const=const2, ...} = getQuals tidtab ty2
612 :			val qual1 = vol1 orelse not vol2
613 :			val qual2 = const1 orelse not const2
614 :			in
615 :			qual1 andalso qual2 andalso compatible tidtab (ty1',ty2')
616 :			end
617 :			| (Ast.EnumRef _, _, _) => isIntegral tidtab rhs
618 :
619 :			| (ty1, ty2, fl) => (* this case is important when type checking function calls if
620 :			convert_function_args_to_pointers is set to false *)
621 :			(equalType tidtab (ty1,ty2)) orelse
622 :			(equalType tidtab (ty1,getCoreType tidtab rhs)))
623 :
624 :			fun isEquable tidtab {ty1, exp1Zero, ty2, exp2Zero} = (* for Eq and Neq *)
625 :			(case (usualUnaryCnv tidtab ty1, exp1Zero, usualUnaryCnv tidtab ty2, exp2Zero) of
626 :			(Ast.Numeric _, _, Ast.Numeric _, _) => usualBinaryCnv tidtab (ty1, ty2) (* get common type *)
627 :			| (Ast.Pointer Ast.Void, _, Ast.Pointer _, _) => SOME ty1
628 :			| (Ast.Pointer _, _, Ast.Pointer Ast.Void, _) => SOME ty2
629 :			| (Ast.Pointer _, _, _, true) => SOME ty1
630 :			| (_, true, Ast.Pointer _, _) => SOME ty2
631 :			| (ty1' as Ast.Pointer _, _, ty2' as Ast.Pointer _, _) =>
632 :			let val (x, _) = composite tidtab (ty1', ty2') (* composite *AFTER* usualUnaryCnv! *)
633 :			in x
634 :			end
635 :			| _ => NONE)
636 :
637 :			fun conditionalExp tidtab {ty1, exp1Zero, ty2, exp2Zero} = (* for Eq and Neq *)
638 :			(case (usualUnaryCnv tidtab ty1, exp1Zero, usualUnaryCnv tidtab ty2, exp2Zero) of
639 :			(Ast.Numeric _, _, Ast.Numeric _, _) => usualBinaryCnv tidtab (ty1, ty2) (* get common type *)
640 :			| ((Ast.StructRef tid1, _, Ast.StructRef tid2, _) |
641 :			(Ast.UnionRef tid1, _, Ast.UnionRef tid2, _)) =>
642 :			if Tid.equal (tid1, tid2) then SOME ty1
643 :			else NONE
644 :			| (Ast.Void, _, Ast.Void, _) => SOME ty1
645 :
646 :			| (Ast.Pointer _, _, Ast.Pointer Ast.Void, _) => SOME ty2
647 :			| (Ast.Pointer Ast.Void, _, Ast.Pointer _, _) => SOME ty1
648 :
649 :			| (ty1' as Ast.Pointer _, _, ty2' as Ast.Pointer _, _) =>
650 :			let val (x, _) = composite tidtab (ty1', ty2') (* composite *AFTER* usualUnaryCnv! *)
651 :			in
652 :			x
653 :			end
654 :
655 :			| (Ast.Pointer _, _, _, true) => SOME ty1
656 :			| (_, true, Ast.Pointer _, _) => SOME ty2
657 :
658 :			| (ty1, _, ty2, _) => NONE)
659 :
660 :			fun isAddable tidtab {ty1, ty2} = (* for Plus *)
661 :			(case (usualUnaryCnv tidtab ty1, usualUnaryCnv tidtab ty2) of
662 :			(Ast.Numeric _, Ast.Numeric _) =>
663 :			(case usualBinaryCnv tidtab (ty1, ty2) (* get common type *)
664 :			of SOME ty => SOME{ty1=ty, ty2=ty, resTy=ty}
665 :			| NONE => NONE)
666 :			| (Ast.Pointer _, Ast.Numeric _) =>
667 :			if isIntegral tidtab ty2
668 :			then SOME{ty1=ty1, ty2=stdInt, resTy=ty1}
669 :			else NONE
670 :			| (Ast.Numeric _, Ast.Pointer _) =>
671 :			if isIntegral tidtab ty1
672 :			then SOME{ty1=stdInt, ty2=ty2, resTy=ty2}
673 :			else NONE
674 :			| _ => NONE)
675 :
676 :			fun isSubtractable tidtab {ty1, ty2} = (* for Plus *)
677 :			(case (usualUnaryCnv tidtab ty1, usualUnaryCnv tidtab ty2) of
678 :			(Ast.Numeric _, Ast.Numeric _) =>
679 :			(case usualBinaryCnv tidtab (ty1, ty2) (* get common type *)
680 :			of SOME ty => SOME{ty1=ty, ty2=ty, resTy=ty}
681 :			| NONE => NONE)
682 :			| (ty1' as Ast.Pointer _, ty2' as Ast.Pointer _) =>
683 :			(case composite tidtab (ty1', ty2') of (* composite *AFTER* usualUnaryCnv *)
684 :			(SOME ty, _) => SOME{ty1=ty, ty2=ty, resTy=stdInt}
685 :			| (NONE, _) => NONE)
686 :			| (Ast.Pointer _, Ast.Numeric _) =>
687 :			if isIntegral tidtab ty2 then SOME{ty1=ty1, ty2=stdInt, resTy=ty1}
688 :			else NONE
689 :			| _ => NONE)
690 :
691 :			fun isComparable tidtab {ty1, ty2} = (* for Eq and Neq *)
692 :			(case (usualUnaryCnv tidtab ty1, usualUnaryCnv tidtab ty2) of
693 :			(Ast.Numeric _, Ast.Numeric _) => usualBinaryCnv tidtab (ty1, ty2) (* get common type *)
694 :			| (ty1' as Ast.Pointer _, ty2' as Ast.Pointer _) =>
695 :			let val (x, _) = composite tidtab (ty1', ty2') (* composite *AFTER* usualUnaryCnv *)
696 :			in x
697 :			end
698 :			| _ => NONE)
699 :
700 :			fun checkFn tidtab (funTy, argTys, isZeroExprs) =
701 :			(case getFunction tidtab funTy of
702 :			NONE => (Ast.Void, ["Called object is not a function."], argTys)
703 :			| SOME(retTy, paramTys) =>
704 :			let
705 :			val paramTys = case paramTys
706 :			of [Ast.Void] => nil (* a function with a single void argument is a function of no args *)
707 :			| _ => paramTys
708 :			fun isAssignableL n x =
709 :			case x
710 :			of (Ast.Ellipses :: _, argl, _) => (nil, List.map (functionArgConv tidtab) argl)
711 :			(* Ellipses = variable arg length function *)
712 :			| (param :: paraml, arg :: argl, isZeroExpr :: isZeroExprs) =>
713 :			let val (strL, paraml) = isAssignableL (n+1) (paraml, argl, isZeroExprs)
714 :			val strL' = if isAssignable tidtab {lhs=param, rhs=arg, rhsExpr0=isZeroExpr}
715 :			then strL
716 :			else
717 :			let val msg = "Bad function call: arg " ^ Int.toString n ^
718 :			" has type " ^ (ctToString tidtab arg)
719 :			^ " but fn parameter has type " ^ (ctToString tidtab param)
720 :			in
721 :			msg :: strL
722 :			end
723 :			in
724 :			(strL', param :: paraml)
725 :			end
726 :			| (nil, nil, _) => (nil, nil)
727 :			(* bugfix 12/Jan/00: the previous bugfix of 15/jun/99 overdid it a little (recursion!).
728 :			the case of a function with a single void arg is
729 :			now handled above in val paramTys = ...
730 :			| ([Ast.Void], nil) => (nil, nil) (* bugfix 15/jun/99: a function with a single void argument
731 :			* is a function of no args *)
732 :			*)
733 :			| ((_, nil, _) | (_, _, nil)) => ( ["Type Warning: function call has too few args"]
734 :			, nil
735 :			)
736 :			| (nil, argl, _) => (["Type Warning: function call has too many args"]
737 :			, List.map (functionArgConv tidtab) argl
738 :			)
739 :			val (msgL, argTys') = isAssignableL 1 (paramTys,argTys, isZeroExprs)
740 :			in
741 :			(retTy, msgL, argTys')
742 :			end)
743 :
744 :			(* The notion of "scalar" types is not defined in e.g. K&R or H&S although
745 :			it is refered to in H&S p218.
746 :			It is used to restrict the type of controlling expressions (e.g. while, do, for, ?:, etc.).
747 :			According to the ISO standard (p24), scalars consist of
748 :			a) arithmetic types (integral and floating types)
749 :			b) pointer types
750 :			This seems to exclude array and function types.
751 :
752 :			However most compilers consider an array type to be scalar (i.e. just consider it a pointer).
753 :
754 :			We shall assume that everthing is a scalar except: functions, unions and structs.
755 :			Lint agrees with this; gcc and SGI cc disagree with this on functions.
756 :			*)
757 :
758 :			fun isScalar tidtab ty =
759 :			case ty
760 :			of Ast.Qual (_,ty) => isScalar tidtab ty
761 :			| Ast.Numeric _ => true
762 :			| Ast.Pointer _ => true
763 :			| Ast.Array _ => true
764 :			| Ast.EnumRef _ => true
765 :			| Ast.TypeRef _ => isScalar tidtab (reduceTypedef tidtab ty)
766 :			| Ast.Function _ => false (* although a function can be viewed as a pointer *)
767 :			| Ast.StructRef _ => false
768 :			| Ast.UnionRef _ => false
769 :			| Ast.Ellipses => false (* can't occur *)
770 :			| Ast.Void => false
771 :			| Ast.Error => false
772 :
773 :			end (* functor TypeUtilFn *)

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0