Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/releases/release-110.31/ckit/src/ast/type-util.sml
ViewVC logotype

Annotation of /sml/releases/release-110.31/ckit/src/ast/type-util.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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