Annotation of /sml/trunk/ckit/src/ast/build-ast.sml

Parent Directory | Revision Log

---

Revision 654 - (view) (download)

1 :	dbm	597	(* Copyright (c) 1998 by Lucent Technologies *)
2 :
3 :			(* buildast.sml
4 :			*
5 :			* Input: a parser tree
6 :			*
7 :			* Output: a type checked abstract syntax tree, a map from
8 :			* expression adornments to types, and mappings from
9 :			* variables (uids) to types and type ids (uids) to types.
10 :			*
11 :			* AUTHORS: Michael Siff (siff@cs.wisc.edu)
12 :			* Satish Chandra (chandra@research.bell-labs.com)
13 :			* Nevin Heintze (nch@research.bell-labs.com)
14 :			* Dino Oliva (oliva@research.bell-labs.com)
15 :			* Dave MacQueen (dbm@research.bell-labs.com)
16 :			*
17 :			* TBD:
18 :			* - needs to be tested for robustness
19 :			* (particularly type table and expression-type map)
20 :			* - add casts to constant expr evaluator
21 :			*)
22 :
23 :			(* Type checking: minor checks not implemented:
24 :			3. no pointer or arrays of bitfields: most compiler (and lint) don't implement this.
25 :			5. only storage-class specifier in a parameter declaration is register.
26 :			*)
27 :
28 :
29 :			(* Notes: Treatment of function pointers.
30 :			In C, the types Function(...) and Pointer(Function(...))
31 :			are almost interchangeable. If f is a function, then
32 :			it can be called using ( *f )(args); if x is a function pointer,
33 :			then the function it points to can be called using x(args)
34 :			(Dennis R. says this was introduced by the pcc compiler, and then adopted by ANSI.)
35 :			The auto-promotion of Function(...) and Pointer(Function(...)) has some
36 :			strange consequences: ( ******f ) is just f.
37 :
38 :			We deal with this as follows:
39 :			1. all expressions of type Function(...) are immediately
40 :			promoted to type Pointer(Function(...))
41 :			2. exceptions to (1) involving sizeof and &
42 :			are handled as special cases in the code for unary operations.
43 :			3. derefs of expressions of type Pointer(Function(...)) are eliminated.
44 :			4. & of functions are eliminated.
45 :			5. function parameters of type Function(...) are promoted to Pointer(Function(...)).
46 :			*)
47 :
48 :			(* Changes to make sometime around April 1st, 99
49 :			2. get rid of redundancy relating to topLevel/global (i.e. remove topLevel param)
50 :			- once it's been tested.
51 :			*)
52 :
53 :			structure BuildAst : BUILD_AST =
54 :			struct
55 :
56 :			type astBundle =
57 :			{ast: Ast.ast,
58 :			tidtab: Bindings.tidBinding Tidtab.uidtab,
59 :			errorCount: int,
60 :			warningCount: int,
61 :			auxiliaryInfo: {aidtab: Tables.aidtab,
62 :			implicits: Tables.aidtab,
63 :			env: State.symtab}}
64 :
65 :			(* imported structures w/abbreviations *)
66 :			(* ----------------------------------- *)
67 :			structure SM = SourceMap
68 :
69 :			structure Aid = Aid
70 :			structure Tid = Tid
71 :			structure Pid = Pid
72 :
73 :			structure PT = ParseTree
74 :			structure Sym = Symbol
75 :			structure B = Bindings
76 :			structure PPL = PPLib
77 :			structure S = State
78 :			structure W = Word
79 :			structure TU = TypeUtil
80 :			structure TT = Tidtab
81 :			structure AT = Aidtab
82 :			structure TypeCheckControl = Config.TypeCheckControl
83 :
84 :			(* local structures *)
85 :			(* ---------------- *)
86 :			(* DBM: an inefficient version of string binary map *)
87 :			structure IdMap = BinaryMapFn (struct
88 :			type ord_key = string
89 :			val compare = String.compare
90 :			end)
91 :
92 :			(* abstract syntax of translation unit in context *)
93 :			type astBundle =
94 :			{ast: Ast.ast,
95 :			tidtab: Bindings.tidBinding Tidtab.uidtab,
96 :			errorCount: int,
97 :			warningCount: int,
98 :			auxiliaryInfo: {aidtab: Tables.aidtab,
99 :			implicits: Tables.aidtab,
100 :			env: State.symtab}}
101 :
102 :			val insert_explicit_coersions = ref false
103 :			val insert_scaling = ref false
104 :			val reduce_sizeof = ref false
105 :			val reduce_assign_ops = ref false
106 :			val multi_file_mode = ref false
107 :			val local_externs_ok = ref true
108 :			val default_signed_char = ref false
109 :
110 :			fun multiFileMode () =
111 :			(insert_explicit_coersions := false;
112 :			insert_scaling := false;
113 :			reduce_sizeof := false;
114 :			reduce_assign_ops := false;
115 :			multi_file_mode := true;
116 :			local_externs_ok := true)
117 :
118 :			fun compilerMode () =
119 :			(insert_explicit_coersions := true;
120 :			insert_scaling := true;
121 :			reduce_sizeof := true;
122 :			reduce_assign_ops := true;
123 :			multi_file_mode := false;
124 :			local_externs_ok := true)
125 :
126 :			fun sourceToSourceMode () =
127 :			(insert_explicit_coersions := false;
128 :			insert_scaling := false;
129 :			reduce_sizeof := false;
130 :			reduce_assign_ops := false;
131 :			multi_file_mode := false;
132 :			local_externs_ok := true)
133 :
134 :			val _ = sourceToSourceMode() (* default is sourceToSource mode *)
135 :
136 :			val perform_type_checking = TypeCheckControl.perform_type_checking
137 :			(* true = do type checking; false = disable type checking;
138 :			Note: with type checking off, there is still some
139 :			rudimentary type processing, but no
140 :			usual unary conversions, usual binary conversions, etc. *)
141 :
142 :			val undeclared_id_error = TypeCheckControl.undeclared_id_error
143 :			(* In ANSI C, an undeclared id is an error;
144 :			in older versions of C, undeclared ids are assumed integer.
145 :			Default value: true (for ANSI behavior) *)
146 :			val convert_function_args_to_pointers =
147 :			TypeCheckControl.convert_function_args_to_pointers
148 :			(* In ANSI C, arguments of functions goverened by prototype
149 :			definitions that have type function or array are not
150 :			promoted to pointer type; however many compilers do this
151 :			promotion.
152 :			Default value: true (to get standard behavior) *)
153 :			val storage_size_check = TypeCheckControl.storage_size_check
154 :			(* Declarations and structure fields must have known storage
155 :			size; maybe you want to turn this check off?
156 :			Default value: true (to get ANSI behavior). *)
157 :
158 :			val allow_non_constant_local_initializer_lists = TypeCheckControl.allow_non_constant_local_initializer_lists
159 :			(* Allow non constant local inializers for aggregates and unions.
160 :			e.g. int x, y, z;
161 :			int a[] = {x, y, z};
162 :			This is allowed gcc *)
163 :
164 :			val (repeated_declarations_ok, resolve_anonymous_structs) =
165 :			if !multi_file_mode then (true, true) else (false, false)
166 :
167 :			fun debugPrBinding (name: string, binding: B.symBinding) =
168 :			(print ("symbol binding: " ^ name ^
169 :			(case binding
170 :			of B.MEMBER _ => " MEMBER"
171 :			| B.TAG _ => " TAG"
172 :			| B.TYPEDEF _ => " TYPEDEF"
173 :			| B.ID _ => " ID")
174 :			^ "\n"))
175 :
176 :
177 :			(* some auxiliary functions *)
178 :			(* ---------------------- *)
179 :			fun toId tid = ".anon" ^ (Tid.toString tid)
180 :
181 :			fun dt2ct {qualifiers,specifiers,storage} =
182 :			{qualifiers=qualifiers,specifiers=specifiers}
183 :
184 :			fun signedNum ik = Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.SIGNED,ik,Ast.SIGNASSUMED)
185 :			fun unsignedNum ik = Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,ik,Ast.SIGNASSUMED)
186 :			val stdInt = TypeUtil.stdInt
187 :
188 :			fun getBindingLoc(B.MEMBER{location,...}) = location
189 :			| getBindingLoc(B.ID{location,...}) = location
190 :			| getBindingLoc(B.TYPEDEF{location,...}) = location
191 :			| getBindingLoc(B.TAG{location,...}) = location
192 :
193 :
194 :			val bogusTid = Tid.new()
195 :			val bogusUid = Pid.new()
196 :			fun bogusMember sym =
197 :			{name = sym, uid = Pid.new(), location = SourceMap.UNKNOWN,
198 :			ctype = Ast.Error, kind = Ast.STRUCTmem} (* dbm: is this kind ok? *)
199 :
200 :			fun isZeroExp(Ast.EXPR (Ast.IntConst 0, _, _)) = true
201 :			| isZeroExp _ = false
202 :
203 :			fun isZeroCoreExp(Ast.IntConst 0) = true
204 :			| isZeroCoreExp _ = false
205 :
206 :			fun getCoreExpr(Ast.EXPR (expr, _, _)) = expr
207 :
208 :			(* check if a parse-tree type is of the `tagged' variety - i.e. it
209 :			* refers to a (struct, union, or enum) type defined elsewhere *)
210 :			fun isTagTy ({specifiers,...}: PT.decltype) =
211 :			let fun sTest (PT.StructTag _) = true
212 :			| sTest (PT.EnumTag _) = true
213 :			| sTest _ = false
214 :			in List.exists sTest specifiers
215 :			end
216 :
217 :			local open Bindings in
218 :			(* main function *)
219 :			fun makeAst (sizes: Sizes.sizes, stateInfo: S.stateInfo,
220 :			errorState : Error.errorState) =
221 :			let
222 :
223 :			(* if there are any parse errors, then don't print any type-checking errors *)
224 :			val _ = if Error.errorCount errorState > 0
225 :			then (Error.noMoreErrors errorState; Error.noMoreWarnings errorState)
226 :			else ()
227 :
228 :			val globalState as {uidTables={ttab,atab,implicits},...} =
229 :			S.initGlobal(stateInfo, errorState)
230 :
231 :			val localState = S.initLocal ()
232 :
233 :			val stateFuns = S.stateFuns(globalState, localState)
234 :
235 :			val {locFuns =
236 :			{pushLoc, popLoc, getLoc, error, warn},
237 :			tidsFuns =
238 :			{pushTids, resetTids},
239 :			tmpVarsFuns =
240 :			{pushTmpVars, resetTmpVars},
241 :			envFuns =
242 :			{topLevel, pushLocalEnv, popLocalEnv, lookSym, bindSym,
243 :			lookSymGlobal, bindSymGlobal, lookLocalScope, getGlobalEnv},
244 :			uidTabFuns =
245 :			{bindAid, lookAid=lookAid0, bindTid, lookTid},
246 :			funFuns =
247 :			{newFunction, getReturnTy, checkLabels, addLabel, addGoto},
248 :			switchFuns =
249 :			{pushSwitchLabels, popSwitchLabels, addSwitchLabel, addDefaultLabel},
250 :			...}
251 :			= stateFuns
252 :
253 :			val bug = Error.bug errorState
254 :			fun convFunError s _ =
255 :			raise Fail("Fatal Bug: extension conversion function " ^ s ^ " not installed yet!")
256 :
257 :
258 :			(* refs for extension conversion functions *)
259 :			val refCNVExp = ref(convFunError "CNVExp" : CnvExt.expressionExt -> Ast.ctype * Ast.expression)
260 :			val refCNVStat = ref(convFunError "CNVStat": CnvExt.statementExt -> Ast.statement)
261 :			val refCNVBinop = ref(convFunError "CNVBinop": {binop: ParseTreeExt.operatorExt, arg1Expr: ParseTree.expression,
262 :			arg2Expr: ParseTree.expression}
263 :			-> Ast.ctype * Ast.expression)
264 :			val refCNVUnop = ref(convFunError "CNVUnop": {unop: ParseTreeExt.operatorExt, argExpr: ParseTree.expression}
265 :			-> Ast.ctype * Ast.expression)
266 :			val refCNVExternalDecl = ref(convFunError "CNVExternalDecl" : CnvExt.externalDeclExt -> Ast.externalDecl list)
267 :			val refCNVSpecifier = ref(convFunError "CNVSpecifier": {isShadow: bool, rest : ParseTree.specifier list}
268 :			-> CnvExt.specifierExt
269 :			-> Ast.ctype)
270 :			val refCNVDeclarator = ref(convFunError "CNVDeclarator": Ast.ctype * CnvExt.declaratorExt
271 :			-> Ast.ctype * string option)
272 :			val refCNVDeclaration = ref(convFunError "CNVDeclaration": CnvExt.declarationExt -> Ast.declaration list)
273 :
274 :			fun CNVExp x = !refCNVExp x
275 :			fun CNVStat x = !refCNVStat x
276 :			fun CNVBinop x = !refCNVBinop x
277 :			fun CNVUnop x = !refCNVUnop x
278 :			fun CNVExternalDecl x = !refCNVExternalDecl x
279 :			fun CNVSpecifier x = !refCNVSpecifier x
280 :			fun CNVDeclarator x = !refCNVDeclarator x
281 :			fun CNVDeclaration x = !refCNVDeclaration x
282 :
283 :			(* miscellaneous utility functions *)
284 :
285 :			(* could be a component of stateFuns *)
286 :			(* indicates a type used before it is defined: structs, unions, enums *)
287 :			(* should never happen for tid bound to a typedef *)
288 :			fun isPartial tid =
289 :			case lookTid tid
290 :			of SOME{ntype=NONE,...} => true
291 :			| _ => false
292 :
293 :			fun isPartialTy(Ast.StructRef tid | Ast.UnionRef tid) = isPartial tid
294 :			| isPartialTy _ = false
295 :
296 :
297 :			fun isLocalScope sym = isSome(lookLocalScope sym)
298 :
299 :			(* redefine lookAid with error recovery behavior *)
300 :			fun lookAid aid =
301 :			case lookAid0 aid
302 :			of NONE =>
303 :			(bug ("lookAid: no type for this expression."
304 :			^ Int.toString aid);
305 :			Ast.Void)
306 :			| SOME ct => ct
307 :
308 :			(* pretty-printer utils *) (* DBM: not used *)
309 :			fun ppCt () =
310 :			PPL.ppToStrm (PPAst.ppCtype () ttab) TextIO.stdOut
311 :
312 :			val ctToString = PPL.ppToString (PPAst.ppCtype () ttab)
313 :
314 :			(* identifier convention: loc : Errors.location *)
315 :
316 :			val isPointer = TU.isPointer ttab
317 :			val isFunction = TU.isFunction ttab (* is real function type; excludes pointer to function *)
318 :			val isNonPointerFunction = TU.isNonPointerFunction ttab
319 :			val isNumberOrPointer = TU.isNumberOrPointer ttab
320 :			val isNumber = TU.isNumber ttab
321 :			val isArray = TU.isArray ttab
322 :			fun deref v =
323 :			(case (TU.deref ttab v)
324 :			of SOME x => x
325 :			| NONE => (error
326 :			("Cannot dereference type " ^ (ctToString v));
327 :			Ast.Void))
328 :
329 :			val getFunction = TU.getFunction ttab
330 :			val isStructOrUnion= TU.isStructOrUnion ttab
331 :			val isEnum = TU.isEnum ttab
332 :			fun lookupEnum v =
333 :			(case (TU.lookupEnum ttab v)
334 :			of SOME x => x
335 :			| NONE => (bug "lookupEnum: invalid enum type";
336 :			LargeInt.fromInt 0))
337 :
338 :			val equalType = TU.equalType ttab
339 :			val isScalar = TU.isScalar ttab
340 :			val isIntegral = TU.isIntegral ttab
341 :			val usualUnaryCnv = TU.usualUnaryCnv ttab
342 :			val usualBinaryCnv = TU.usualBinaryCnv ttab
343 :			val isConst = TU.isConst ttab
344 :			val isEquable = TU.isEquable ttab
345 :			val isAddable = TU.isAddable ttab
346 :			val isSubtractable = TU.isSubtractable ttab
347 :			val isComparable = TU.isComparable ttab
348 :			val conditionalExp = TU.conditionalExp ttab
349 :			val compatible = TU.compatible ttab
350 :			val functionArgConv = TU.functionArgConv ttab
351 :			val isFunctionPrototype = TU.isFunctionPrototype ttab
352 :			val getCoreType = TU.getCoreType ttab
353 :
354 :			fun composite (ty1, ty2) =
355 :			case TU.composite ttab (ty1, ty2)
356 :			of (res, nil) => res
357 :			| (res, errL) =>
358 :			(List.map error errL;
359 :			res)
360 :
361 :			val hasKnownStorageSize = TU.hasKnownStorageSize ttab
362 :			val preArgConv = TU.preArgConv ttab
363 :			val cnvFunctionToPointer2Function = TU.cnvFunctionToPointer2Function ttab
364 :
365 :			fun checkQuals ty = TU.checkQuals ttab ty
366 :
367 :			fun wrapSTMT(coreStmt: Ast.coreStatement) : Ast.statement =
368 :			Ast.STMT (coreStmt, Aid.new (), getLoc())
369 :
370 :			fun wrapDECL(coreExtDecl: Ast.coreExternalDecl) : Ast.externalDecl =
371 :			Ast.DECL(coreExtDecl, Aid.new (), getLoc())
372 :
373 :			fun wrapEXPR (ty, coreExpr) =
374 :			let val ty = cnvFunctionToPointer2Function ty
375 :			(* all expressions of type Function are promoted to Pointer(Function)
376 :			* exceptions (&, sizeof) are handled in unops *)
377 :			(* Strictly speaking, arrays should also be converted to pointers here;
378 :			however code using array expressions deal with the array case directly (e.g. Sub, Deref);
379 :			Caution: if we were to make this change, we still need to know it was an array!
380 :			Where is the right place to do this conversion? *)
381 :			val adorn = bindAid ty
382 :			in (ty, Ast.EXPR (coreExpr, adorn, getLoc()))
383 :			end
384 :
385 :			val simplifyAssignOps = SimplifyAssignOps.simplifyAssignOps
386 :			{lookAid=lookAid, getCoreType=getCoreType, wrapEXPR=wrapEXPR,
387 :			getLoc=getLoc, topLevel=topLevel, bindSym=bindSym, pushTmpVars=pushTmpVars}
388 :
389 :			fun mkFunctionCt (retTy, argTys) =
390 :			(if isNonPointerFunction retTy
391 :			then error "Return type of function cannot be function type."
392 :			else ();
393 :			if isArray retTy
394 :			then error "Return type of function cannot be array type."
395 :			else ();
396 :			let val argTys =
397 :			if convert_function_args_to_pointers then
398 :			List.map preArgConv argTys
399 :			else List.map cnvFunctionToPointer2Function argTys
400 :			in
401 :			Ast.Function(retTy, argTys)
402 :			end)
403 :
404 :			fun getStorageClass sym =
405 :			case lookSym sym
406 :			of SOME(B.ID{stClass,...}) => SOME stClass
407 :			| _ => NONE
408 :
409 :			fun checkFn (funTy,argTys,exprs) =
410 :			let val isZeroExprs = List.map isZeroExp exprs
411 :			in
412 :			case TU.checkFn ttab (funTy, argTys, isZeroExprs)
413 :			of (res, nil, args) => (res, args)
414 :			| (res, errL, args) =>
415 :			(List.map error errL;
416 :			(res, args))
417 :			end
418 :
419 :			(* DBM: should this go in State? or be defined in terms of a more
420 :			* primitive operation in State like the former insertOpAid? *)
421 :			fun noteImplicitConversion (Ast.EXPR (_, aid, _), ty) = AT.insert(implicits,aid,ty)
422 :
423 :			fun wrapCast (ty, expr as (Ast.EXPR(_, aid', loc'))) =
424 :			if CTypeEq.eqCType(getCoreType(lookAid aid'), getCoreType ty) then expr (* DBM: gen. equality on types *)
425 :			(* 7/29/99: tentative fix for spurious casts
426 :			old code: if lookAid aid' = ty then expr (* DBM: gen. equality on types *)
427 :			*)
428 :			else let
429 :			val aid = bindAid ty
430 :			in
431 :			if !insert_explicit_coersions then
432 :			Ast.EXPR(Ast.Cast(ty, expr), aid, loc')
433 :			else
434 :			(noteImplicitConversion(expr, ty);
435 :			expr)
436 :			end
437 :
438 :			fun sizeof ty =
439 :			LargeInt.fromInt (#bytes (Sizeof.byteSizeOf {sizes=sizes, err=error, warn=warn, bug=bug} ttab ty))
440 :
441 :			fun isLval (expr, ty) =
442 :			case expr
443 :			of Ast.Member(Ast.EXPR (expr'', aid, _), _) =>
444 :			isLval (expr'', lookAid aid)
445 :			| (Ast.Id _ | Ast.Sub _ | Ast.Arrow _ | Ast.Deref _) => true
446 :			| _ => false
447 :
448 :			fun checkAssignableLval (expr, ty, s) =
449 :			(* check we can assign to this expression,
450 :			* and generate error messages if not *)
451 :			if isLval (expr, ty) then
452 :			if isConst ty then
453 :			error
454 :			("Type Error: lhs of assignment is const"
455 :			^ (if s = "" then "." else (" in " ^ s ^ ".")))
456 :			else (case expr
457 :			of Ast.Id _ =>
458 :			if isArray ty then
459 :			error
460 :			("Type Error: lhs of assignment is an array (not a modifiable lval)"
461 :			^ (if s = "" then "." else (" " ^ s ^ ".")))
462 :			else ()
463 :			| _ => ())
464 :			else
465 :			error
466 :			("Type Error: lhs of assignment is not an lvalue"
467 :			^ (if s = "" then "." else (" " ^ s ^ ".")))
468 :
469 :			fun isAssignableTys {lhsTy, rhsTy, rhsExprOpt : Ast.coreExpression option} =
470 :			let val rhsExpr0 = (case rhsExprOpt
471 :			of SOME rhsExpr => isZeroCoreExp rhsExpr
472 :			| NONE => false)
473 :			in TU.isAssignable ttab {lhs=lhsTy, rhs=rhsTy, rhsExpr0=rhsExpr0}
474 :			end
475 :
476 :			fun checkAssignableTys (x as {lhsTy, rhsTy, rhsExprOpt}) =
477 :			if not(isAssignableTys x) then
478 :			let val lhs = ctToString lhsTy
479 :			val rhs' = ctToString (usualUnaryCnv rhsTy)
480 :			val rhs = ctToString rhsTy
481 :			in error
482 :			("Type Error: rval of type " ^ rhs
483 :			^ " cannot be assigned to lval of type " ^ lhs ^ ".")
484 :			end
485 :			else ()
486 :
487 :			fun checkAssign {lhsTy,lhsExpr,rhsTy,rhsExprOpt : Ast.coreExpression option} =
488 :			if perform_type_checking then
489 :			(checkAssignableLval(lhsExpr, lhsTy, "");
490 :			checkAssignableTys {lhsTy=lhsTy,rhsTy=rhsTy,rhsExprOpt=rhsExprOpt})
491 :			else ()
492 :
493 :			fun isTYPEDEF({storage,...} : PT.decltype) =
494 :			if List.exists (fn PT.TYPEDEF => true | _ => false) storage (* any typedefs? *)
495 :			then (case storage of
496 :			[PT.TYPEDEF] => true (* must be exactly one typedef *)
497 :			| _ => (error "illegal use of TYPEDEF";
498 :			true))
499 :			else false
500 :
501 :			fun declExprToDecl errorStr (decr, PT.EmptyExpr) = decr
502 :			| declExprToDecl errorStr (decr, _) = (error errorStr; decr)
503 :
504 :			(* checks for illegal rebinding within current local scope, for other
505 :			* than objects and functions *)
506 :			fun checkNonIdRebinding (sym, ty, kind: string) : unit =
507 :			case lookLocalScope sym
508 :			of SOME(B.TYPEDEF{location=loc, ...}) =>
509 :			(error ("illegal redeclaration of " ^ kind ^ (Sym.name sym) ^
510 :			";\n previously declared as typedef at " ^
511 :			SM.locToString loc))
512 :			| SOME(B.MEMBER{location=loc, ...}) =>
513 :			(error ("illegal redeclaration of " ^ kind ^ (Sym.name sym) ^
514 :			";\n previously declared as member at " ^
515 :			SM.locToString loc))
516 :			| SOME(B.TAG{location=loc, ...}) =>
517 :			(error ("illegal redeclaration of " ^ kind ^ (Sym.name sym) ^
518 :			";\n previously declared as tag at " ^
519 :			SM.locToString loc))
520 :			| NONE => () (* not previously bound in local scope *)
521 :			| _ => bug "checkNonIdRebinding: unexpected binding"
522 :
523 :
524 :			(* checks for illegal rebinding within current local scope
525 :			* only called in processDecr for "object" declaration *)
526 :			fun checkIdRebinding (sym, newTy, newStatus: Ast.declStatus, {globalBinding}) : Ast.declStatus * Ast.ctype * (Pid.uid option) =
527 :			case (if globalBinding then lookSymGlobal sym else lookLocalScope sym)
528 :			of SOME (B.ID{status=oldStatus,kind,location,ctype=oldTy,uid, ...}) =>
529 :			if globalBinding orelse topLevel()
530 :			then let val status =
531 :			case (newStatus, oldStatus)
532 :			of (Ast.DEFINED,Ast.DEFINED) =>
533 :			(error
534 :			(case kind
535 :			of Ast.FUNCTION _ =>
536 :			("illegal redefinition of identifier "
537 :			^ (Sym.name sym) ^
538 :			";\n previously defined as function at " ^
539 :			SM.locToString location)
540 :			| Ast.NONFUN =>
541 :			("illegal redefinition of identifier "
542 :			^ (Sym.name sym) ^
543 :			";\n previously declared with initializer at " ^
544 :			SM.locToString location));
545 :			Ast.DEFINED)
546 :			| (Ast.DEFINED,_) => Ast.DEFINED
547 :			| (_,Ast.DEFINED) => Ast.DEFINED
548 :			| (Ast.DECLARED,_) => Ast.DECLARED
549 :			| (_,Ast.DECLARED) => Ast.DECLARED
550 :			| _ => Ast.IMPLICIT
551 :			val ty =
552 :			case kind
553 :			of Ast.FUNCTION _ =>
554 :			if equalType (newTy, oldTy) then oldTy
555 :			else
556 :			(case composite(newTy,oldTy)
557 :			of SOME ty => ty
558 :			| NONE =>
559 :			(error
560 :			("illegal redeclaration of function " ^
561 :			(Sym.name sym) ^
562 :			" has type incompatible with previous " ^
563 :			"declaration at " ^
564 :			SM.locToString location);
565 :			newTy))
566 :			| Ast.NONFUN =>
567 :			if equalType (newTy, oldTy) then oldTy
568 :			else
569 :			(case composite(newTy, oldTy)
570 :			of SOME ty => ty
571 :			| NONE =>
572 :			(error
573 :			("illegal redeclaration of identifier "
574 :			^ (Sym.name sym) ^
575 :			";\n type incompatible with previous \
576 :			\declaration at " ^
577 :			SM.locToString location);
578 :			newTy))
579 :			in (status,ty,SOME uid)
580 :			end
581 :			else (* no redefinition *)
582 :			(error
583 :			("illegal redeclaration of "^ (Sym.name sym) ^
584 :			" in nested scope;\n previous declaration at " ^
585 :			SM.locToString location);
586 :			(newStatus,newTy, NONE))
587 :			| NONE => (newStatus,newTy, NONE) (* not previously bound in local scope *)
588 :			| _ => (error ((Sym.name sym)^" is not a variable");
589 :			(newStatus,newTy, NONE)) (* not previously bound in local scope *)
590 :
591 :
592 :			(* code for calling initializer normalizer *)
593 :			fun normalize(ty, expr) =
594 :			InitializerNormalizer.normalize{lookTid=lookTid, bindAid=bindAid,
595 :			initType=ty, initExpr=expr}
596 :
597 :
598 :			(* type check initializer:
599 :			recursively descend into type and initializer, checking as we go.
600 :			NB 1: if type is unions and structs, then don't generate errors when initializer is simple
601 :			NB 2: if type is array then *do* generate errors when initializer is simple *)
602 :
603 :
604 :			fun TCInitializer(ctype as (Ast.TypeRef _ | Ast.Qual _), expr) =
605 :			TCInitializer(getCoreType ctype, expr) (* the following TCInitializer cases expect coretypes *)
606 :			| TCInitializer (Ast.Array(opt, ctype), Ast.Aggregate exprs) =
607 :			(case (opt, Int32.fromInt(List.length exprs))
608 :			of (NONE, _) =>
609 :			bug "TCInitializer: array size should be filled in by now?"
610 :			| (SOME(x, _), y) =>
611 :			if x = y then () (* Int32 equality *)
612 :			else if x < y then
613 :			error "TCInitializer: badly formed array initializer: \
614 :			\too many initializers"
615 :			else error "TCInitializer: badly formed array initializer: \
616 :			\not enough initializers";
617 :			List.app (fn e => TCInitializer(ctype, e)) exprs)
618 :			| TCInitializer (Ast.Array _, _) =
619 :			error "badly formed array initializer: expected {"
620 :			| TCInitializer (Ast.StructRef tid, Ast.Aggregate exprs) =
621 :			(case lookTid tid
622 :			of SOME{ntype=SOME(B.Struct(tid,fields)),...} =>
623 :			let fun f ((fieldType, _, _) :: l, expr :: exprs) =
624 :			(TCInitializer(fieldType, expr);
625 :			f (l, exprs))
626 :			| f (nil, nil) = ()
627 :			| f (_, nil) =
628 :			error
629 :			"badly formed struct initializer: not enough initializers"
630 :			| f (nil, _) =
631 :			error
632 :			"badly formed struct initializer: too many initializers"
633 :			in f (fields, exprs)
634 :			end
635 :			| NONE => bug "TCInitializer: lookTid failed"
636 :			| _ => error "TCInitializer: ill-formed StructRef type")
637 :			| TCInitializer (Ast.UnionRef tid, Ast.Aggregate exprs) =
638 :			(case lookTid tid
639 :			of SOME{ntype=SOME(B.Union(tid,(fieldTy, _)::fields)),...} =>
640 :			(case exprs
641 :			of [expr] => TCInitializer(fieldTy, expr)
642 :			| _ :: _ =>
643 :			error
644 :			"badly formed union initializer: \
645 :			\initializer has too many elements"
646 :			| nil =>
647 :			error "badly formed union initializer: empty initializer")
648 :			| SOME{ntype=SOME (B.Union(tid,_)), ...} =>
649 :			error "empty union"
650 :			| NONE => bug "TCInitializer: lookTid failed"
651 :			| _ => error "TCInitializer: ill-formed UnionRef type")
652 :			| TCInitializer (ty as (Ast.StructRef _ | Ast.UnionRef _), Ast.Simple(Ast.EXPR(coreExp, aid, _))) =
653 :			if isAssignableTys {lhsTy=ty, rhsTy=lookAid aid, rhsExprOpt=SOME coreExp}
654 :			then ()
655 :			else error "type of initializer is incompatible with type of lval"
656 :			| TCInitializer (Ast.Pointer(Ast.Numeric (_,_,_,Ast.CHAR,_)),
657 :			Ast.Simple(Ast.EXPR(Ast.StringConst _, _, _))) = ()
658 :			| TCInitializer (ty, Ast.Aggregate([Ast.Simple(Ast.EXPR(coreExp, aid, _))])) =
659 :			if isScalar ty then
660 :			if isAssignableTys {lhsTy=ty, rhsTy=lookAid aid,
661 :			rhsExprOpt=SOME coreExp}
662 :			then ()
663 :			else error "type of initializer is incompatible with type of lval"
664 :			else
665 :			error "illegal aggregate initializer"
666 :
667 :			| TCInitializer (_, Ast.Aggregate _) =
668 :			error "illegal aggregate initializer"
669 :			| TCInitializer (ty, Ast.Simple(Ast.EXPR(coreExp, aid, _))) =
670 :			if isAssignableTys {lhsTy=ty, rhsTy=lookAid aid,
671 :			rhsExprOpt=SOME coreExp}
672 :			then ()
673 :			else error "type of initializer is incompatible with type of lval"
674 :
675 :			(* check form of initializer *)
676 :			fun checkInitializer (ty, initExpr, auto) =
677 :			let
678 :			val initExpr' =
679 :			case initExpr of
680 :			Ast.Aggregate _ => if isArray ty orelse (case isStructOrUnion ty of SOME _ => true | NONE => false)
681 :			then normalize(ty, initExpr)
682 :			else initExpr
683 :			| Ast.Simple(Ast.EXPR(Ast.StringConst _, _, _)) => normalize(ty, initExpr)
684 :			| _ => initExpr
685 :			(* the purpose of normalize is the handle the case of strings as initializers,
686 :			* and to pad out curly-brace initializers
687 :			*)
688 :			(* old code: 3/10/00
689 :			* case (initExpr, auto) of
690 :			* (Ast.Aggregate _, _) => normalize(ty, initExpr)
691 :			* | (_, false) => normalize(ty, initExpr)
692 :			* | (Ast.Simple(Ast.EXPR(Ast.StringConst _, _, _)), _) => normalize(ty, initExpr)
693 :			* | (_, true) => initExpr
694 :			*)
695 :			val ty = case getCoreType ty
696 :			of Ast.Array(NONE, ctype) =>
697 :			(case initExpr'
698 :			of Ast.Aggregate inits =>
699 :			let val len = List.length inits
700 :			val i = Int32.fromInt len
701 :			val (_, expr) = wrapEXPR(stdInt, Ast.IntConst i)
702 :			in
703 :			if len=0 then warn "Array has zero size." else ();
704 :			Ast.Array(SOME(i, expr), ctype)
705 :			end
706 :			| _ => (error
707 :			"badly formed array initializer: missing \"{\"";
708 :			ty))
709 :			| _ => ty
710 :			in TCInitializer(ty, initExpr');
711 :			(initExpr', ty)
712 :			end
713 :
714 :			(* processing declarator parse trees *)
715 :
716 :			fun processDeclarator (typ as {qualifiers,specifiers,storage},decr) =
717 :			let fun vardeclToTypeNameLoc (typ as {qualifiers, specifiers},decr) =
718 :			let fun mkTyp spc = {qualifiers=[], specifiers=[spc]}
719 :			fun addQual q = {qualifiers=q::qualifiers, specifiers=specifiers}
720 :			in case decr
721 :			of PT.VarDecr x => (typ,SOME x,getLoc())
722 :			| PT.PointerDecr x =>
723 :			vardeclToTypeNameLoc (mkTyp (PT.Pointer typ),x)
724 :			| PT.ArrayDecr (x,sz) =>
725 :			vardeclToTypeNameLoc (mkTyp (PT.Array (sz,typ)),x)
726 :			| PT.FuncDecr (x,lst) =>
727 :			vardeclToTypeNameLoc (mkTyp (PT.Function{retType=typ,params=lst}),x)
728 :			| PT.QualDecr (q,decr) =>
729 :			vardeclToTypeNameLoc (addQual q, decr)
730 :			| PT.EmptyDecr => (typ, NONE, getLoc())
731 :			| PT.EllipsesDecr => (mkTyp PT.Ellipses, SOME("**ellipses**"), getLoc())
732 :			| PT.MARKdeclarator(loc, decr) =>
733 :			(pushLoc loc;
734 :			vardeclToTypeNameLoc(typ, decr)
735 :			before popLoc ())
736 :			| PT.DecrExt _ => (typ, NONE, getLoc()) (* should call decr extension? *)
737 :			end
738 :			val ({qualifiers,specifiers},sOpt, loc) =
739 :			vardeclToTypeNameLoc ({qualifiers=qualifiers,
740 :			specifiers=specifiers},
741 :			decr)
742 :			in ({qualifiers=qualifiers,specifiers=specifiers,storage=storage},sOpt, loc)
743 :			end
744 :
745 :			(* processDecr :
746 :			* Ast.ctype * Ast.storageClass * bool
747 :			* -> (ParseTree.declarator * ParseTree.expression)
748 :			* * ((Ast.id * Ast.expression) list)
749 :			* -> ((Ast.id * Ast.expression) list)
750 :			* to be used by both external (global) decls and internal (statement
751 :			* level - within function body) decls.
752 :			* After type and storage class are specified, designed to be used with
753 :			* a fold function.
754 :			*)
755 :
756 :			fun cnvInitExpression(PT.InitList exprs) =
757 :			Ast.Aggregate(map cnvInitExpression exprs)
758 :			| cnvInitExpression(PT.MARKexpression(loc, expr)) =
759 :			(pushLoc loc;
760 :			cnvInitExpression expr
761 :			before popLoc ())
762 :			| cnvInitExpression(expr) =
763 :			Ast.Simple(#2(cnvExpression expr))
764 :
765 :			and processDecr (ty,sc,topLevel0) (decr,expr) =
766 :	dbm	639	let val (ty,varNameOpt,loc) = mungeTyDecr (ty, decr)
767 :	dbm	597	val varName =
768 :			case varNameOpt
769 :			of SOME name => name
770 :			| NONE =>
771 :			(error
772 :			"missing declarator in declaration - \
773 :			\filling with <missing_declarator>.";
774 :			"<missing_declarator>")
775 :
776 :			val hasInitializer = (case expr of
777 :			PT.EmptyExpr => false
778 :			| _ => true)
779 :
780 :			val varSym = Sym.object varName
781 :
782 :			val _ = if (topLevel0 = topLevel()) then ()
783 :			else bug "inconsistency of topLevel!"
784 :
785 :			val auto = case (topLevel0, sc)
786 :			of (true, Ast.AUTO) =>
787 :			(error "`auto' not allowed in top-level declarations";
788 :			false)
789 :			| (true, Ast.REGISTER) =>
790 :			(error "`register' not allowed in top-level declarations";
791 :			false)
792 :			| (true, _) => true
793 :			| (false, Ast.EXTERN) =>
794 :			(if !local_externs_ok then ()
795 :			else error "`extern' not allowed in local declarations";
796 :			false)
797 :			| (false, Ast.STATIC) => false
798 :			| (false, _) => true
799 :			(* local declarations are auto unless declared static *)
800 :
801 :			(* ISO p71: initExprs must be constant if
802 :			a) they are in an initilizer list for an object of aggregate or union type
803 :			b) the object has static storage duration
804 :			*)
805 :			(* Note: should really reduce constants arith exprs to simple constants *)
806 :			fun constCheck(Ast.EXPR((Ast.StringConst _ | Ast.IntConst _ | Ast.RealConst _),_,_)) = true
807 :			| constCheck(Ast.EXPR(Ast.QuestionColon(e1, e2, e3), _, _))
808 :			= constCheck e1 andalso constCheck e2 andalso constCheck e3
809 :			| constCheck(Ast.EXPR(Ast.Binop(_, e1, e2), _, _))
810 :			= constCheck e1 andalso constCheck e2
811 :			| constCheck(Ast.EXPR(Ast.Unop(_, e1), _, _)) = constCheck e1
812 :			| constCheck(Ast.EXPR(Ast.Cast(_, e1), _, _)) = constCheck e1
813 :			| constCheck(Ast.EXPR(Ast.EnumId _, _, _)) = true
814 :			| constCheck(Ast.EXPR(Ast.SizeOf _, _, _)) = true
815 :			| constCheck(Ast.EXPR(Ast.AddrOf _, _, _)) = true
816 :			| constCheck(Ast.EXPR(Ast.Id id, _, _)) =
817 :			(* id must be a function or an array (note: a function pointer won't do) *)
818 :			let val {ctype, ...} = id
819 :			in
820 :			isFunction ctype orelse isArray ctype
821 :			end
822 :			| constCheck _ = false
823 :			fun constCheckIE'(Ast.Simple expr) = constCheck expr
824 :			| constCheckIE'(Ast.Aggregate exprl)
825 :			= List.foldl (fn (x, y) => (constCheckIE' x) andalso y) true exprl
826 :			fun constCheckIE(Ast.Simple expr) =
827 :			(if topLevel0 orelse sc = Ast.STATIC orelse sc = Ast.EXTERN
828 :			then
829 :			if constCheck expr then ()
830 :			else error("Illegal initializer: object has static storage duration, but initializer is not constant.")
831 :			else if isArray ty
832 :			then
833 :			if constCheck expr then ()
834 :			else error("Illegal initializer: object is an array, but initializer is not constant.")
835 :			else ())
836 :
837 :			| constCheckIE x = if allow_non_constant_local_initializer_lists orelse constCheckIE' x then ()
838 :			else error("Illegal initializer: initializer list elements must be constants.")
839 :
840 :			(*** Checking initializers: from ISO p72.
841 :			1. if toplevel or static or extern or array then initializer must be const
842 :			2. case of type:
843 :			scalar: initializer must be a single expression, optionally enclosed in {}
844 :			aggregate or union:
845 :			a) apply normalize
846 :			b) type check
847 :			- but don't generate errors due to simple for unions and structs
848 :			- do generate errors due to simple for arrays
849 :			*)
850 :
851 :			val (id, ty) =
852 :			if isFunction ty then (* declaring (NOT defining) a function *)
853 :			(* CHECK: sc should be either DEFAULT, or EXTERN or STATIC? *)
854 :			let val (status, newTy, uidOpt) =
855 :			checkIdRebinding(varSym, ty, Ast.DECLARED, {globalBinding=true})
856 :			val uid = case uidOpt of
857 :			SOME uid => uid
858 :			| NONE => Pid.new()
859 :	dbm	639	val id = {name = varSym, uid = uid, location = loc,
860 :	dbm	597	ctype = newTy, stClass = sc, status = status, global = true,
861 :			kind = Ast.FUNCTION{hasFunctionDef=false}}
862 :			val binding = ID id
863 :			in bindSymGlobal(varSym, binding);
864 :			(id, newTy)
865 :			end
866 :			else (* not a function type *)
867 :			let val status = if hasInitializer then Ast.DEFINED else Ast.DECLARED
868 :			val hasExtern = (case sc of Ast.EXTERN => true | _ => false)
869 :			(* if hasExtern then force globalization of this binding *)
870 :			val (status,ty,uidOpt) =
871 :			checkIdRebinding(varSym, ty, status, {globalBinding=hasExtern})
872 :			val uid = case uidOpt of SOME uid => uid | NONE => Pid.new()
873 :
874 :	dbm	639	val id = {name = varSym, uid = uid, location = loc,
875 :	dbm	597	ctype = ty, stClass = sc, status = status, global = topLevel() orelse hasExtern,
876 :			kind = Ast.NONFUN}
877 :			(* always rebind, even if there was a previous binding in
878 :			* scope *)
879 :			in if hasExtern then bindSymGlobal (varSym, ID id)
880 :			else bindSym (varSym, ID id);
881 :			(id, ty)
882 :			end
883 :
884 :			(* Delay processing of initializer until we've added a binding for
885 :			the variable. This implements the "left-to-right" processing
886 :			strategy of C -- i.e. we process the declaration before we process
887 :			the initializer.
888 :			This means that
889 :			int x=43;
890 :			main () {
891 :			int x = x+2;
892 :			}
893 :			does not have its intuitive meaning (at least for functional programmers).
894 :			In other words, initializers are not quite let statements!
895 :
896 :			This does lead to a problem: sometimes we don't know the full type
897 :			of something until we've looked at the initializer
898 :			e.g. int [] = {1,2,3};
899 :			So, we might have to fix up the type!
900 :			*)
901 :
902 :	dbm	654	(* DBM: return fixed id as well, to fix Bug 19 *)
903 :			val (initExprOpt, ty, id) =
904 :	dbm	597	case expr
905 :	dbm	654	of PT.EmptyExpr => (NONE, ty, id)
906 :	dbm	597	| _ =>
907 :			let
908 :			val e = cnvInitExpression expr
909 :			val _ = constCheckIE e
910 :			val (e',ty') = checkInitializer(ty, e, auto)
911 :	dbm	654	val id' =
912 :			if equalType(ty', ty) then id (* no fix for id required *)
913 :	dbm	597	else (* fix up type of id *)
914 :	dbm	654	(case lookSym varSym
915 :			of SOME(B.ID x) =>
916 :			let val {name, uid, location, ctype, stClass,
917 :			status, global, kind} = x
918 :			val newid = {name=name, uid=uid, location=location,
919 :			ctype=ty', stClass=stClass,
920 :			status=status, global=global,
921 :			kind=kind}
922 :			in bindSym (varSym, ID newid);
923 :			newid
924 :			end
925 :			| _ => id) (* can never arise: id must have ID binding *)
926 :			in (SOME e', ty', id')
927 :	dbm	597	end
928 :
929 :			(* Now do storage size check: can't do it earlier, because type might
930 :			be incomplete, and only completed by processing the initializer. *)
931 :
932 :			val _ =
933 :			if storage_size_check then
934 :			if hasKnownStorageSize ty then ()
935 :			else (case sc
936 :			of Ast.EXTERN => ()
937 :			| _ =>
938 :			error
939 :			("Storage size of `"
940 :			^ Sym.name varSym
941 :			^ "' is not known (e.g. incomplete type, void)"))
942 :			else ()
943 :
944 :			in (id, initExprOpt)
945 :			end
946 :
947 :
948 :			(* processTypedef :
949 :			* Ast.ctype -> ParseTree.declarator -> ()
950 :			* (storage class simply meant to discriminate between top-level (STATIC) and
951 :			* local (AUTO))
952 :			*)
953 :			and processTypedef ty decr =
954 :			if !multi_file_mode then (* version of processTypede for multi_file_mode *)
955 :			let
956 :	dbm	639	val (ty,nameOpt,loc) = mungeTyDecr (ty, decr)
957 :	dbm	597	val name =
958 :			case nameOpt
959 :			of SOME name => name
960 :			| NONE =>
961 :			(error
962 :			"Missing declarator in typedef - filling with missing_typedef_name";
963 :			"missing_typedef_name")
964 :
965 :			val sym = Sym.typedef name
966 :
967 :			val tidOpt =
968 :			(case lookLocalScope sym
969 :			of SOME(TYPEDEF{ctype=ty, location=loc',...}) =>
970 :			(case ty
971 :			of Ast.TypeRef tid =>
972 :			if repeated_declarations_ok then SOME tid
973 :			else (error
974 :			("Redeclaration of typedef `" ^
975 :			(Sym.name sym) ^
976 :			"'; previous declaration at " ^
977 :			SM.locToString loc');
978 :			NONE)
979 :			| _ => (error
980 :			("Redeclaration of typedef `" ^
981 :			(Sym.name sym) ^
982 :			"'; previous declaration at " ^
983 :			SM.locToString loc');
984 :			NONE))
985 :			| SOME binding =>
986 :			(error
987 :			("Redeclaration of `" ^
988 :			(Sym.name sym) ^
989 :			"' as a typedef; previous declaration at " ^
990 :			SM.locToString (getBindingLoc binding));
991 :			NONE)
992 :			| NONE => NONE) (* not bound locally *)
993 :
994 :
995 :			val tid =
996 :			case tidOpt
997 :			of SOME tid => tid
998 :			| NONE => Tid.new () (* create a new named type id *)
999 :
1000 :			val ty' = Ast.TypeRef tid
1001 :			(* store actual typdef symbol mapped to named type id *)
1002 :			val _ = checkNonIdRebinding(sym, ty', "typedef ")
1003 :
1004 :	dbm	639	val binding = TYPEDEF{name = sym, uid = Pid.new(), location = loc,
1005 :	dbm	597	ctype = ty'}
1006 :
1007 :			(* store named type id mapped to typedef in named-type table *)
1008 :			in bindSym(sym, binding);
1009 :			bindTid (tid, {name=SOME name, ntype=SOME(B.Typedef (tid,ty)),
1010 :			global = topLevel(), location=getLoc()});
1011 :			tid
1012 :			end
1013 :			else (* standard version of processTypedef *)
1014 :			(* In time the two version should be combined. *)
1015 :	dbm	639	let val (ty,nameOpt,loc) = mungeTyDecr (ty, decr)
1016 :	dbm	597	val name =
1017 :			case nameOpt
1018 :			of SOME name => name
1019 :			| NONE =>
1020 :			(error
1021 :			"Missing declarator in typedef - filling with missing_typedef_name";
1022 :			"missing_typedef_name")
1023 :			val sym = Sym.typedef name
1024 :
1025 :			(* create a new named type id *)
1026 :			val tid = Tid.new ()
1027 :			val ty' = Ast.TypeRef tid
1028 :
1029 :			val _ = checkNonIdRebinding(sym, ty', "typedef ")
1030 :
1031 :	dbm	639	val binding = TYPEDEF{name = sym, uid = Pid.new(), location = loc,
1032 :	dbm	597	ctype = ty'}
1033 :
1034 :			(* store named type id mapped to typedef in named-type table *)
1035 :			in bindSym (sym, binding);
1036 :			bindTid (tid, {name=SOME name, ntype=SOME (B.Typedef (tid,ty)),
1037 :			global = topLevel(), location=getLoc()});
1038 :			tid
1039 :			end
1040 :
1041 :
1042 :			(* like processDeclarator, except it munges a Ast.ctype with
1043 :			* a PT.declarator *)
1044 :	dbm	639	and mungeTyDecr (ty: Ast.ctype, decr : PT.declarator)
1045 :			: Ast.ctype * string option * SourceMap.location =
1046 :	dbm	597	case decr
1047 :	dbm	639	of PT.VarDecr str => (ty,SOME str,getLoc())
1048 :	dbm	597	| PT.PointerDecr decr => mungeTyDecr (Ast.Pointer ty, decr)
1049 :			| PT.ArrayDecr (decr,PT.EmptyExpr) => mungeTyDecr(Ast.Array (NONE, ty), decr)
1050 :			| PT.ArrayDecr (decr,sz) =>
1051 :			let val (i, aexpr) = case evalExpr sz (* cannot be EmptyExpr *)
1052 :			of
1053 :			(SOME i, _, aexpr, _) => (if i=0 then warn "Array has zero size." else ();
1054 :			(i, aexpr))
1055 :			| (NONE, _, aexpr, _) => (error "Array must have constant size.";
1056 :			(0, aexpr))
1057 :			in
1058 :			mungeTyDecr(Ast.Array (SOME(i, aexpr), ty), decr)
1059 :			end
1060 :
1061 :			| PT.FuncDecr (decr,lst) =>
1062 :			let fun folder (dt,decr) =
1063 :			let val ty = (dt2ct o #1) (processDeclarator (dt,decr))
1064 :			in cnvCtype (false, ty)
1065 :			end
1066 :			val argTys = List.map folder lst
1067 :			in mungeTyDecr(mkFunctionCt(ty, argTys), decr)
1068 :			end
1069 :			| PT.QualDecr (PT.CONST,decr) =>
1070 :			let val ty' = Ast.Qual (Ast.CONST,ty)
1071 :			(* dpo: is this check necessary?
1072 :			* Doesn't the 2nd call get the same info? *)
1073 :			val {redundantConst, ...} = checkQuals ty
1074 :			val {redundantConst=redundantConst', ...} = checkQuals ty'
1075 :			in if not redundantConst andalso redundantConst'
1076 :			then error "Duplicate `const'."
1077 :			else ();
1078 :			mungeTyDecr (ty', decr)
1079 :			end
1080 :			| PT.QualDecr (PT.VOLATILE,decr) =>
1081 :			let val ty' = Ast.Qual (Ast.VOLATILE,ty)
1082 :			val {redundantVolatile, ...} = checkQuals ty
1083 :			val {redundantVolatile=redundantVolatile', ...} = checkQuals ty'
1084 :			in if not(redundantVolatile) andalso redundantVolatile'
1085 :			then error "Duplicate `volatile'."
1086 :			else ();
1087 :			mungeTyDecr (ty', decr)
1088 :			end
1089 :	dbm	639	| PT.EllipsesDecr => (Ast.Ellipses, SOME "**ellipses**", getLoc())
1090 :			| PT.EmptyDecr => (ty, NONE, getLoc())
1091 :	dbm	597	| PT.MARKdeclarator(loc, decr) =>
1092 :			(pushLoc loc;
1093 :			mungeTyDecr(ty, decr)
1094 :			before popLoc ())
1095 :	dbm	639	| PT.DecrExt ext =>
1096 :			let val (t,n) = CNVDeclarator (ty, ext) in (t,n,getLoc()) end
1097 :	dbm	597
1098 :
1099 :			(* --------------------------------------------------------------------
1100 :			* cnvExternalDecl : ParseTree.externalDecl -> Ast.externalDecl list
1101 :			*
1102 :			* Converts a parse-tree top-level declaration into an ast top-level
1103 :			* declaration by adding the necessary symbols and types to the
1104 :			* environment and recursively converting statements of function bodies.
1105 :			* -------------------------------------------------------------------- *)
1106 :
1107 :			and cnvExternalDecl (PT.ExternalDecl(PT.DeclarationExt ext)) =
1108 :			let val declarations = CNVDeclaration ext
1109 :			in
1110 :			List.map (fn x => wrapDECL(Ast.ExternalDecl x)) declarations
1111 :			end
1112 :
1113 :			| cnvExternalDecl (PT.ExternalDecl(PT.MARKdeclaration (loc,decl))) =
1114 :			(pushLoc loc;
1115 :			cnvExternalDecl(PT.ExternalDecl decl)
1116 :			before popLoc ())
1117 :
1118 :			| cnvExternalDecl (PT.ExternalDecl(PT.Declaration(dt as {qualifiers, specifiers, storage},
1119 :			declExprs))) : Ast.externalDecl list =
1120 :			(* The following code is almost identical to corresponding case in processDecls ...
1121 :			Any changes made here should very likely be reflected in changes to the processDecls code. *)
1122 :			if isTYPEDEF dt then
1123 :			let val ct = {qualifiers=qualifiers, specifiers=specifiers}
1124 :			val decls = List.map (declExprToDecl "initializers in typedef") declExprs
1125 :			in (* global typedefs *)
1126 :			if List.null decls then (warn "empty typedef"; [])
1127 :			else
1128 :			let val ty = cnvCtype (false, ct)
1129 :			val tidl = List.map (processTypedef ty) decls
1130 :			in List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=NONE, tid=x}))) tidl
1131 :			end
1132 :			end
1133 :			else (* global variable and struct declarations *)
1134 :			let val isShadow = List.null declExprs andalso isTagTy dt
1135 :			(* isShadow does not necessarily mean "shadows a previous definition";
1136 :			rather, it refers to empty type declarations of the form
1137 :			struct t;
1138 :			enum e;
1139 :			Of course, the real use of these declarations is
1140 :			for defining mutually recursive structs/unions
1141 :			that reuse previously defined ids i.e. for shadowing....
1142 :			Note: if we had
1143 :			struct t x;
1144 :			then this would not be a shadow,
1145 :			hence the null declExprs test.
1146 :			*)
1147 :			val (ty,sc) = cnvType (isShadow, dt)
1148 :			in if isShadow
1149 :			then let fun getTid (Ast.StructRef tid) = SOME({strct=true}, tid)
1150 :			| getTid(Ast.UnionRef tid) = SOME({strct=false}, tid)
1151 :			| getTid(Ast.Qual(_, ct)) = getTid ct (* ignore qualifiers *)
1152 :			| getTid _ = NONE (* don't deref typerefs *)
1153 :			in
1154 :			case getTid ty of
1155 :			SOME(strct, tid) => [wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=SOME strct, tid=tid}))]
1156 :			| NONE => []
1157 :			end
1158 :			else
1159 :			let val idExprs = List.map (processDecr(ty,sc,true)) declExprs
1160 :			in List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.VarDecl x))) idExprs
1161 :			end
1162 :			end
1163 :
1164 :			| cnvExternalDecl (PT.FunctionDef {retType as {qualifiers,specifiers,storage},
1165 :			funDecr, krParams: PT.declaration list, body}) =
1166 :			(* function definitions *)
1167 :			let
1168 :	dbm	639	val (funTy, tagOpt, funLoc) = processDeclarator (retType, funDecr)
1169 :	dbm	597	val funName = case tagOpt
1170 :			of SOME tag => tag
1171 :			| NONE =>
1172 :			(bug
1173 :			"Missing function name - \
1174 :			\filling with missing_function_name";
1175 :			"missing_function_name")
1176 :			val (retType, args) =
1177 :			case funTy
1178 :			of {specifiers=[PT.Function {retType,params}],...} => (retType, params)
1179 :			| _ =>(error "ill-formed function declaration";
1180 :			({qualifiers=[],specifiers=[]}, nil))
1181 :
1182 :			val retType' = cnvCtype (false,retType)
1183 :
1184 :			val sc = cnvStorage storage
1185 :
1186 :			(* check validity of storage class *)
1187 :			val _ = case sc
1188 :			of Ast.DEFAULT => ()
1189 :			| Ast.EXTERN => ()
1190 :			| Ast.STATIC => ()
1191 :			| _ => (error "`auto' and `register' are not allowed \
1192 :			\in function declarations")
1193 :
1194 :			val argTyIdOpts = List.map processDeclarator args
1195 :			fun unzip3((x, y, z) :: l) =
1196 :			let val (xl, yl, zl) = unzip3 l
1197 :			in
1198 :			(x :: xl, y :: yl, z :: zl)
1199 :			end
1200 :			| unzip3 nil = (nil,nil, nil)
1201 :
1202 :			fun zip3(x :: xl, y :: yl, z :: zl) = (x, y, z) :: (zip3(xl, yl, zl))
1203 :			| zip3 _ = nil
1204 :
1205 :			val (argTys, argIdOpts, locs) = unzip3 argTyIdOpts
1206 :
1207 :			fun noDeclType{specifiers=nil,qualifiers=nil,storage=nil} = true
1208 :			| noDeclType _ = false
1209 :
1210 :			val krParamsAdmitted = List.all noDeclType argTys (* if true, K&R params are admitted *)
1211 :
1212 :			(* enter a local scope - push a new symbol table *)
1213 :			val _ = pushLocalEnv ()
1214 :
1215 :			(* insert (and convert) argument types in this symbol table *)
1216 :			(* this needs to be done left to right because the first
1217 :			* argument could define a type used in later args *)
1218 :			val argTyScList = List.map (fn ty => cnvType(false,ty)) argTys
1219 :
1220 :			(* create a (ctype * storageClass) IdMap.map *)
1221 :			val argIds' =
1222 :			let
1223 :			fun iter ((SOME s) :: l) = (s :: (iter l))
1224 :			| iter (NONE :: l) = (warn "unnamed function argument";
1225 :			nil)
1226 :			| iter nil = nil
1227 :			in
1228 :			case argTyIdOpts of
1229 :			[({specifiers=[PT.Void], qualifiers=nil, storage=nil}, NONE, _)] => nil
1230 :			(* special case of function definition f(void) {...} *)
1231 :			| _ => iter argIdOpts
1232 :			end
1233 :
1234 :			(* zipped list will be size of shorter list - if one is shorter *)
1235 :			val argTyScIdLocList = zip3 (argTyScList, argIds', locs)
1236 :			fun folder ((tySc,id,loc),mp) = IdMap.insert (mp, id, (tySc,false,loc))
1237 :			(* false component means hasn't been matched with K&R parameters spec *)
1238 :			val argMap = List.foldl folder IdMap.empty argTyScIdLocList
1239 :
1240 :			(* check if krParams are ok *)
1241 :			val _ = if null krParams orelse krParamsAdmitted then ()
1242 :			else error "mixing of K&R params and prototype style params not allowed"
1243 :
1244 :			(* rectify additional types from K&R style parameters *)
1245 :			val argMap =
1246 :			let
1247 :			fun folder (decl,argMap) =
1248 :			(case decl
1249 :			of PT.MARKdeclaration(loc,decl') =>
1250 :			(pushLoc loc;
1251 :			folder(decl',argMap) before
1252 :			popLoc())
1253 :			| PT.DeclarationExt _ =>
1254 :			(error "Declaration extensions not permitted in K&R parameter declarations";
1255 :			argMap)
1256 :			| PT.Declaration(decltype as {storage,...}, decrExprs) =>
1257 :			if isTYPEDEF decltype then (error "typedef in function parameter declaration";
1258 :			argMap)
1259 :			else let val decrs = List.map (declExprToDecl "initializer in function declaration") decrExprs
1260 :			val (ty,sc) = cnvType (false, decltype)
1261 :			fun folder' (decr, argMap) =
1262 :	dbm	639	let val (ty, sOpt, loc) = mungeTyDecr (ty, decr)
1263 :	dbm	597	val s =
1264 :			case sOpt
1265 :			of SOME s =>
1266 :			(case IdMap.find (argMap,s)
1267 :			of NONE =>
1268 :			(error "K&R parameter not in function's identifier list";
1269 :			s)
1270 :			| SOME (_,matched,_) =>
1271 :			if matched then
1272 :			(error ("repeated K&R declaration for parameter "^ s);
1273 :			s)
1274 :			else s)
1275 :			| NONE =>
1276 :			(error "Unnamed K&R style parameter - \
1277 :			\filling with unnamed_KR_parameter";
1278 :			"<unnamed_KR_parameter>")
1279 :	dbm	639	val argMap = IdMap.insert
1280 :			(argMap, s, ((ty,sc),true,loc))
1281 :	dbm	597	in argMap
1282 :			end
1283 :			in List.foldl folder' argMap decrs
1284 :			end)
1285 :			in
1286 :			List.foldl folder argMap krParams
1287 :			end
1288 :
1289 :			fun mapper id =
1290 :			let val (p, loc) =
1291 :			case IdMap.find (argMap, id)
1292 :			of SOME (p,_,loc) => (p, loc)
1293 :			| NONE => (bug "mapper: inconsistent arg map";
1294 :			((Ast.Error, Ast.DEFAULT), SM.UNKNOWN))
1295 :			in (p, id, loc)
1296 :			end
1297 :
1298 :			val argTyScIdLocList' = List.map mapper argIds'
1299 :
1300 :			fun checkStorageClass ((_,Ast.REGISTER),_, _) = ()
1301 :			| checkStorageClass ((_,Ast.DEFAULT),_, _) = () (* DBM: ??? *)
1302 :			| checkStorageClass _ =
1303 :			error "Only valid storage class for function parameters is `register'."
1304 :
1305 :			val _ = List.map checkStorageClass argTyScIdLocList'
1306 :
1307 :			(* insert function name in global scope *)
1308 :			val argTys' = #1 (ListPair.unzip (#1 (unzip3 argTyScIdLocList')))
1309 :			(* ASSERT: argument type list is null iff not a prototype style defn *)
1310 :			val funTy' = mkFunctionCt (retType', if null krParams then argTys' else nil)
1311 :			val funSym = Sym.func funName
1312 :			val (status, newTy, uidOpt) =
1313 :			checkIdRebinding(funSym, funTy', Ast.DEFINED, {globalBinding=true})
1314 :			val uid = case uidOpt of
1315 :			SOME uid => uid
1316 :			| NONE => Pid.new()
1317 :	dbm	639	val funId = {name = funSym, uid = uid, location = funLoc,
1318 :	dbm	597	ctype = funTy', stClass = sc, status = status,
1319 :			kind = Ast.FUNCTION{hasFunctionDef = true}, global = true}
1320 :			val binding = ID funId
1321 :
1322 :			val _ = bindSymGlobal(funSym, binding)
1323 :			(* note: we've already pushed a local env for the function args, so
1324 :			we are no longer at top level -- we must use bindSymGlobal here! *)
1325 :
1326 :			(* insert the arguments in the local symbol table *)
1327 :			val argPids =
1328 :			let fun bindArg ((ty,sc),name,loc) =
1329 :			let
1330 :			val ty = preArgConv ty (* array and function replaced by pointers *)
1331 :			val sym = Sym.object name
1332 :			val kind = Ast.NONFUN
1333 :			(* argument types cannot have function type:
1334 :			even if declared as function types,
1335 :			they are treated as function pointers. *)
1336 :			val id = {name = sym, uid = Pid.new(), location = loc,
1337 :			ctype = ty, stClass = sc, status=Ast.DECLARED,
1338 :			kind = kind, global = false}
1339 :			val _ = case lookLocalScope sym of
1340 :			NONE => ()
1341 :			| SOME _ => error ("Repeated function parameter " ^ (Sym.name sym))
1342 :			in bindSym(sym, ID id);
1343 :			id
1344 :			end
1345 :			in List.map bindArg argTyScIdLocList'
1346 :			end
1347 :
1348 :			(* set new function context (labels and returns) *)
1349 :			val _ = newFunction retType'
1350 :			(* get new type declarations (tids) from retType and argTys *)
1351 :			val newtids = resetTids ()
1352 :
1353 :			val bodyStmt = cnvStatement body
1354 :			(* note: what one might think of as an empty function body would
1355 :			* actually be a compound statement consisting of an empty list
1356 :			* of statements - thus all functions consist of one statement. *)
1357 :
1358 :			in popLocalEnv ();
1359 :			case checkLabels ()
1360 :			of NONE => ()
1361 :			| SOME (lab,loc) =>
1362 :			Error.error(errorState, loc,
1363 :			"Label " ^ ((Sym.name lab))
1364 :			^ "used but not defined.");
1365 :			(List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl({shadow=NONE, tid=x})))) newtids) @
1366 :			[wrapDECL(Ast.FunctionDef (funId, argPids, bodyStmt))]
1367 :			end
1368 :
1369 :			| cnvExternalDecl (PT.MARKexternalDecl (loc,extDecl)) =
1370 :			(pushLoc loc;
1371 :			cnvExternalDecl extDecl
1372 :			before popLoc ())
1373 :			| cnvExternalDecl (PT.ExternalDeclExt extDecl) =
1374 :			CNVExternalDecl extDecl
1375 :
1376 :			(* --------------------------------------------------------------------
1377 :			* cnvStatement : ParseTree.statement -> Ast.statement ternary_option
1378 :			*
1379 :			* Converts a parse-tree statement into an ast statement by adding the
1380 :			* necessary symbols and types to the environment and recursively converting
1381 :			* statements and expressions.
1382 :			*
1383 :			* A statement could be a type (or struct/union/enum) declaration which
1384 :			* only effects the environment, so return type is Ast.statement list
1385 :			* where the empty list is returned for such declarations.
1386 :			* A parse-tree statement can also be a variable declaration which
1387 :			* declares multiple variables in which case the result will be multiple
1388 :			* Ast statements. All other cases will result in one Ast.statement
1389 :			* being returned.
1390 :			*
1391 :			* In the parse tree, most (in principle all) statements have their
1392 :			* locations marked by being wrapped in a MARKstatement constructor.
1393 :			* In the ast, each core statement is wrapped by a STMT constructor
1394 :			* which also contains the location in the source file from where
1395 :			* the statement came. This is reflected in the structure of the
1396 :			* function: each MARKstatement causes the marked location to pushed
1397 :			* onto the stack in the environment, the wrapped statement is
1398 :			* recursively converted, then wrapped in a STMT constructor with the
1399 :			* location; finally the location is popped off the location stack in
1400 :			* the environment.
1401 :			* -------------------------------------------------------------------- *)
1402 :
1403 :			and processDecls ((PT.Decl decl) :: rest, astdecls: Ast.declaration list list)
1404 :			: Ast.declaration list * PT.statement list =
1405 :			let fun processDeclaration (PT.Declaration(dt as {qualifiers, specifiers, ...}, declExprs)) =
1406 :			(* The following code is almost identical to corresponding case in cnvExternalDecl *)
1407 :			(* but we have deal with struct definitions -- cnvExternalDecl doesn't *)
1408 :			(* have to deal with them because makeAst' catches these at top level *)
1409 :			(* Any changes made here should very likely be reflected in changes to the cnvExternalDecl code. *)
1410 :			if isTYPEDEF dt then
1411 :			let val ct = {qualifiers=qualifiers, specifiers=specifiers}
1412 :			val decrs = List.map (declExprToDecl "initializer in typedef") declExprs
1413 :			in
1414 :			if List.null decrs
1415 :			then (warn "empty typedef";
1416 :			astdecls)
1417 :			else
1418 :			let val ty = cnvCtype (false, ct)
1419 :			val tidl = List.map (processTypedef ty) decrs
1420 :			val newtids = resetTids ()
1421 :			in (List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) tidl) ::
1422 :			(List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids) :: astdecls
1423 :			(* note: must process declarations left to right since we
1424 :			* could have e.g. int i=45, j = i; *)
1425 :			end
1426 :			end
1427 :			else
1428 :			let val isShadow = List.null declExprs andalso isTagTy dt
1429 :			val (ty,sc) = cnvType (isShadow, dt)
1430 :			(* ASSERT: null(tidsContext) *)
1431 :			(* ASSERT: not at top level (i.e. topLevel() => false) *)
1432 :			in if isShadow
1433 :			then let fun getTid (Ast.StructRef tid) = SOME({strct=true}, tid)
1434 :			| getTid(Ast.UnionRef tid) = SOME({strct=false}, tid)
1435 :			| getTid(Ast.Qual(_, ct)) = getTid ct (* ignore qualifiers *)
1436 :			| getTid _ = NONE (* don't deref typerefs *)
1437 :			in
1438 :			(case getTid ty of
1439 :			SOME(strct, tid) => [Ast.TypeDecl{shadow=SOME strct, tid=tid}]
1440 :			| NONE => []) ::
1441 :			(List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) (resetTids ()))(*should always be null*)
1442 :			:: astdecls
1443 :			end
1444 :			else let
1445 :			val idExprs =
1446 :			List.map (processDecr (ty,sc,false)) declExprs
1447 :			(* note: must process declarations left to right since we
1448 :			* could have e.g. int i=45, j = i; *)
1449 :			val newtids = resetTids ()
1450 :			in (List.map Ast.VarDecl idExprs) ::
1451 :			(List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids) :: astdecls
1452 :			(* DBM: push decl lists onto astdecls in reverse order since
1453 :			* astdecls will be reversed before flattening *)
1454 :			end
1455 :			end
1456 :			| processDeclaration(PT.DeclarationExt ext) =
1457 :			let val declarations = CNVDeclaration ext
1458 :			in declarations :: astdecls
1459 :			end
1460 :			| processDeclaration(PT.MARKdeclaration(newloc, decl)) =
1461 :			(pushLoc newloc;
1462 :			processDeclaration decl
1463 :			before popLoc ())
1464 :			in
1465 :			processDecls(rest, processDeclaration decl)
1466 :			end
1467 :
1468 :	dbm	639	| processDecls((PT.MARKstatement (newloc,stmt as PT.Decl _)) :: rest,
1469 :			astdecls) =
1470 :	dbm	597	(pushLoc newloc;
1471 :			processDecls(stmt :: rest, astdecls)
1472 :			before popLoc ())
1473 :
1474 :	dbm	639	| processDecls((PT.MARKstatement (newloc,stmt as PT.MARKstatement _)) :: rest,
1475 :			astdecls ) =
1476 :			processDecls(stmt :: rest, astdecls)
1477 :
1478 :	dbm	597	| processDecls (rest, astdecls) = (List.concat(rev astdecls), rest)
1479 :
1480 :			(* cnvStatement : PT.statement -> Ast.statement *)
1481 :			and cnvStatement (stmt: PT.statement): Ast.statement =
1482 :			(case stmt
1483 :			of PT.Expr PT.EmptyExpr => wrapSTMT(Ast.Expr NONE)
1484 :			| PT.Expr e =>
1485 :			let val (_, e') = cnvExpression e
1486 :			in wrapSTMT(Ast.Expr(SOME e'))
1487 :			end
1488 :			| PT.Compound stmts =>
1489 :			(pushLocalEnv ();
1490 :			let val (decls,rest) = processDecls(stmts,[])
1491 :			val stmts = List.map cnvStatement rest
1492 :			val newtids = resetTids ()
1493 :			val newTmps = resetTmpVars()
1494 :			val tmpdecls = List.map (fn pid => Ast.VarDecl(pid, NONE)) newTmps
1495 :			val typedecls = List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids
1496 :			in wrapSTMT(Ast.Compound(decls@tmpdecls@typedecls,stmts))
1497 :			end
1498 :			before popLocalEnv ())
1499 :			| PT.Decl _ =>
1500 :			(* shouldn't occur; process decls anyway, but discard them *)
1501 :			(error "unexpected declaration";
1502 :			processDecls([stmt],[]);
1503 :			(* may violate assertion topLevel() = false for processDecls *)
1504 :			wrapSTMT(Ast.ErrorStmt))
1505 :			| PT.While (expr, stmt) =>
1506 :			let val (exprTy, expr') = cnvExpression expr
1507 :			val stmt = cnvStatement stmt
1508 :			in if perform_type_checking andalso not(isScalar exprTy)
1509 :			then error
1510 :			"Type Error: condition of while statement is not scalar."
1511 :			else ();
1512 :			wrapSTMT(Ast.While (expr',stmt))
1513 :			end
1514 :			| PT.Do (expr, stmt) =>
1515 :			let val (exprTy, expr') = cnvExpression expr
1516 :			val stmt = cnvStatement stmt
1517 :			in if perform_type_checking andalso not(isScalar exprTy)
1518 :			then error
1519 :			"Type Error: condition of do statement is not scalar."
1520 :			else ();
1521 :			wrapSTMT(Ast.Do (expr',stmt))
1522 :			end
1523 :			| PT.For (expr1,expr2,expr3,stmt) =>
1524 :			let val expr1' =
1525 :			(case expr1
1526 :			of PT.EmptyExpr => NONE
1527 :			| _ => SOME(#2 (cnvExpression expr1)))
1528 :			val expr2' =
1529 :			(case expr2
1530 :			of PT.EmptyExpr => NONE
1531 :			| _ =>
1532 :			let val (exprTy,expr2') = cnvExpression expr2
1533 :			in if perform_type_checking andalso not(isScalar exprTy)
1534 :			then error
1535 :			"Type Error: condition of for statement is not scalar."
1536 :			else ();
1537 :			SOME expr2'
1538 :			end)
1539 :			val expr3' =
1540 :			(case expr3
1541 :			of PT.EmptyExpr => NONE
1542 :			| _ => SOME(#2 (cnvExpression expr3)))
1543 :			val stmt = cnvStatement stmt
1544 :			in wrapSTMT(Ast.For (expr1',expr2',expr3',stmt))
1545 :			end
1546 :			| PT.Labeled (s,stmt) =>
1547 :			let val stmt = cnvStatement stmt
1548 :			val labelSym = Sym.label s
1549 :			val label = addLabel(labelSym, getLoc())
1550 :			in wrapSTMT(Ast.Labeled (label, stmt))
1551 :			end
1552 :			| PT.CaseLabel (expr, stmt) =>
1553 :			let val n = case expr of
1554 :			PT.EmptyExpr => (error "Non-constant case label."; 0)
1555 :			| _ => (case evalExpr expr of (* cannot be EmptyExpr *)
1556 :			(SOME i, _, _, sizeofFl) =>
1557 :			(if sizeofFl andalso not(!reduce_sizeof)
1558 :			then warn("sizeof in case label not preserved in source-to-source mode.")
1559 :			else ();
1560 :			i)
1561 :			| (NONE, _, _, _) => (error "Non-constant case label."; 0))
1562 :			in case addSwitchLabel n
1563 :			of NONE => ()
1564 :			| SOME msg => error msg;
1565 :			wrapSTMT(Ast.CaseLabel (n, (cnvStatement stmt)))
1566 :			end
1567 :			| PT.DefaultLabel stmt =>
1568 :			let val stmt = cnvStatement stmt
1569 :			in case addDefaultLabel ()
1570 :			of NONE => ()
1571 :			| SOME msg => error msg;
1572 :			wrapSTMT(Ast.DefaultLabel (stmt))
1573 :			end
1574 :			| PT.Goto s =>
1575 :			let val labSym = Sym.label s
1576 :			val label = addGoto(labSym, getLoc())
1577 :			in wrapSTMT(Ast.Goto label)
1578 :			end
1579 :			| PT.Break => wrapSTMT(Ast.Break)
1580 :			| PT.Continue => wrapSTMT(Ast.Continue)
1581 :			| PT.Return expr =>
1582 :			let val (exprTy, expr') =
1583 :			case expr
1584 :			of PT.EmptyExpr => (Ast.Void, NONE)
1585 :			| _ =>
1586 :			let val (ty,expr) = cnvExpression expr
1587 :			in (ty, SOME expr)
1588 :			end
1589 :			val returnTy = getReturnTy ()
1590 :			val _ =
1591 :			if perform_type_checking then
1592 :			(case returnTy
1593 :			of SOME returnTy =>
1594 :			if isAssignableTys{lhsTy=returnTy,
1595 :			rhsTy=exprTy,
1596 :			rhsExprOpt=case expr'
1597 :			of SOME expr'' =>
1598 :			SOME(getCoreExpr expr'')
1599 :			| NONE => NONE}
1600 :			then ()
1601 :			else
1602 :			let val lhs = ctToString returnTy
1603 :			val rhs = ctToString exprTy
1604 :			in case expr of
1605 :			PT.EmptyExpr => warn "missing return value."
1606 :			(* lcc gives this a warning: check ISO standard... *)
1607 :			| _ => error
1608 :			( "Type Error: returning expression has illegal type " ^ rhs
1609 :			^ ".\n Function has return type " ^ lhs ^ "."
1610 :			)
1611 :			end
1612 :			| NONE => ())
1613 :			else ()
1614 :			in wrapSTMT((Ast.Return expr'))
1615 :			end
1616 :			| PT.IfThen (expr,stmt) =>
1617 :			let val (exprTy, expr') = cnvExpression expr
1618 :			val stmt = cnvStatement stmt
1619 :			in if perform_type_checking andalso not(isScalar exprTy)
1620 :			then error
1621 :			"Type Error: condition of if statement is not scalar."
1622 :			else ();
1623 :			wrapSTMT(Ast.IfThen (expr',stmt))
1624 :			end
1625 :			| PT.IfThenElse (expr, stmt1, stmt2) =>
1626 :			let val (exprTy, expr') = cnvExpression expr
1627 :			val stmt1 = cnvStatement stmt1
1628 :			val stmt2 = cnvStatement stmt2
1629 :			in if perform_type_checking andalso not(isScalar exprTy)
1630 :			then error
1631 :			"Type Error: condition of if statement is not scalar."
1632 :			else ();
1633 :			wrapSTMT(Ast.IfThenElse (expr', stmt1, stmt2))
1634 :			end
1635 :			| PT.Switch (expr, stmt) =>
1636 :			let val (exprTy, expr') = cnvExpression expr
1637 :			val _ =
1638 :			if perform_type_checking andalso not(isIntegral exprTy)
1639 :			then error
1640 :			"The controlling expression of switch statement \
1641 :			\is not of integral type."
1642 :			else ()
1643 :			val _ = pushSwitchLabels ()
1644 :			val stmt = cnvStatement stmt
1645 :			in popSwitchLabels ();
1646 :			wrapSTMT(Ast.Switch(expr',stmt))
1647 :			end
1648 :			| PT.StatExt stmt =>
1649 :			CNVStat stmt
1650 :			| PT.MARKstatement (newloc,stmt) =>
1651 :			(pushLoc newloc;
1652 :			cnvStatement stmt
1653 :			before popLoc ()))
1654 :
1655 :
1656 :			(* --------------------------------------------------------------------
1657 :			* cnvExpression : ParseTree.expression -> Ast.ctype * Ast.expression
1658 :			*
1659 :			* Converts a parse-tree expression into an ast expression by
1660 :			* recursively converting subexpressions.
1661 :			*
1662 :			* In the ast, each core statement is wrapped by an EXPR constructor
1663 :			* which also contains the nearest marked location in the source file
1664 :			* from which the expression came. This is reflected in the structure
1665 :			* of the function: each parse-tree expression is converted into an ast
1666 :			* core expression and then wrapped in EXPR along with the current
1667 :			* location indicated by the environment and a unique
1668 :			* adornment. Subsequently each ast expression can be referred to by
1669 :			* its adornment. Along the way, the type of each expression is
1670 :			* calculated and stored in the environment in a map from expression
1671 :			* adornments to types.
1672 :			*
1673 :			* The fact that types are computed for each expression does _not_ mean
1674 :			* that this is a type checker. The bare minimum type checking is done
1675 :			* to allow for the expression-adornment-type map to be built. (* DBM ??? *)
1676 :			* -------------------------------------------------------------------- *)
1677 :
1678 :			and cnvExpression expr =
1679 :			let
1680 :			fun numberOrPointer (ty, s) =
1681 :			if isNumberOrPointer ty then ()
1682 :			else error ("Type Error: operand of " ^ s ^
1683 :			" must be a number or a pointer.")
1684 :
1685 :			fun number (ty, s) =
1686 :			if isNumber ty then ()
1687 :			else error("Type Error: operand of " ^ s ^ " must be a number.")
1688 :
1689 :			fun mkBinopExp((ty1, ty2, resTy), expr1, expr2, binop) =
1690 :			let val resTy = getCoreType resTy
1691 :			in
1692 :			wrapEXPR(resTy, Ast.Binop (binop, wrapCast(ty1, expr1), wrapCast(ty2, expr2)))
1693 :			end
1694 :
1695 :			fun mkUnopExp((ty, resTy), expr, unop) =
1696 :			let val resTy = getCoreType resTy
1697 :			in
1698 :			wrapEXPR(resTy, Ast.Unop (unop, wrapCast(ty, expr)))
1699 :			end
1700 :
1701 :			fun mkBinaryAssignOpExp((newTy1, newTy2, resTy), ty1, expr1, ty2, expr2, assignOp, simpleOp) =
1702 :			let val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1, rhsTy=resTy, rhsExprOpt=NONE}
1703 :			fun getTy(Ast.EXPR(_, adorn, _)) = getCoreType(lookAid adorn)
1704 :			in
1705 :			if !reduce_assign_ops then
1706 :			simplifyAssignOps(processBinop, simpleOp, {preOp=true}, expr1, expr2)
1707 :			else
1708 :			(if CTypeEq.eqCType(getTy expr1, getCoreType newTy1) then ()
1709 :			else noteImplicitConversion(expr1, newTy1);
1710 :			if CTypeEq.eqCType(getTy expr2, getCoreType newTy2) then ()
1711 :			else noteImplicitConversion(expr2, newTy2);
1712 :			mkBinopExp((ty1, ty2, ty1), expr1, expr2, assignOp)) (* result type is (getCoreType ty1) *)
1713 :			end
1714 :
1715 :			and mkUnaryAssignOpExp((newTy1, newTy2, resTy), ty1, expr1, preOp, assignOp, simpleOp) =
1716 :			let
1717 :			val (oneTy, one) = wrapEXPR(stdInt, Ast.IntConst 1) (* implicit one constant
1718 :			-- all unaryassignops use one *)
1719 :			val expr2 = one
1720 :			val ty2 = oneTy
1721 :			val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1, rhsTy=resTy, rhsExprOpt=NONE}
1722 :			in
1723 :			if !reduce_assign_ops then
1724 :			simplifyAssignOps(processBinop, simpleOp, preOp, expr1, expr2)
1725 :			else
1726 :			mkUnopExp((ty1, ty1), expr1, assignOp) (* result type is (getCoreType ty1) *)
1727 :			end
1728 :
1729 :			and scaleExpr (size: LargeInt.int, expr as Ast.EXPR(_, adorn, _)) =
1730 :			let
1731 :			val ty1 = lookAid adorn
1732 :			val expr1 = expr
1733 :			val ty2 = stdInt
1734 :			val (_, expr2) = wrapEXPR(ty2, Ast.IntConst size)
1735 :			in
1736 :			processBinop(ty1, expr1, ty2, expr2, PT.Times)
1737 :			end
1738 :
1739 :			and scalePlus(ty1, expr1, ty2, expr2) = (* scale integer added to pointer *)
1740 :			case (!insert_scaling, isPointer ty1, isPointer ty2) of
1741 :			(true, true, false) => let val (ty2, expr2) = scaleExpr(sizeof(deref ty1), expr2)
1742 :			in
1743 :			(ty1, expr1, ty2, expr2)
1744 :			end
1745 :			| (true, false, true) => let val (ty1, expr1) = scaleExpr(sizeof(deref ty2), expr1)
1746 :			in
1747 :			(ty1, expr1, ty2, expr2)
1748 :			end
1749 :			| _ => (ty1, expr1, ty2, expr2) (* no change *)
1750 :
1751 :			and scaleMinus(ty1, ty2, expr2) = (* scale integer subtracted from pointer *)
1752 :			case (!insert_scaling, isPointer ty1, isPointer ty2) of
1753 :			(true, true, false) => let val (ty2, expr2) = scaleExpr(sizeof(deref ty1), expr2)
1754 :			in
1755 :			(ty2, expr2)
1756 :			end
1757 :			| _ => (ty2, expr2) (* no change *)
1758 :
1759 :			and plusOp (ty1, ty2) = (* type check plus *)
1760 :			if perform_type_checking then
1761 :			(case isAddable {ty1=ty1, ty2=ty2}
1762 :			of SOME{ty1, ty2, resTy} => (ty1, ty2, resTy)
1763 :			| NONE => (error
1764 :			"Type Error: Unacceptable operands of \"+\" or \"++\".";
1765 :			(ty1, ty2, ty1)))
1766 :			else
1767 :			(ty1, ty2, ty1)
1768 :
1769 :			and minusOp (ty1, ty2) =
1770 :			if perform_type_checking then
1771 :			(case isSubtractable {ty1=ty1, ty2=ty2} of
1772 :			SOME{ty1, ty2, resTy} => (ty1, ty2, resTy)
1773 :			| NONE => (error
1774 :			"Type Error: Unacceptable operands of \"-\" or \"--\".";
1775 :			(ty1, ty2, ty1)))
1776 :			else
1777 :			(ty1, ty2, ty1)
1778 :
1779 :			and processBinop(ty1, expr1, ty2, expr2, expop) =
1780 :			let
1781 :			fun eqOp(ty1, exp1, ty2, exp2) = (* see H&S p208 *)
1782 :			if perform_type_checking then
1783 :			(case isEquable {ty1=ty1, exp1Zero=isZeroExp exp1,
1784 :			ty2=ty2, exp2Zero=isZeroExp exp2}
1785 :			of SOME ty => (ty, ty, signedNum Ast.INT)
1786 :			| NONE =>
1787 :			(error
1788 :			"Type Error: bad types for arguments of eq/neq operator.";
1789 :			(ty1, ty2, signedNum Ast.INT)))
1790 :			else (ty1, ty2, signedNum Ast.INT)
1791 :
1792 :			fun comparisonOp(ty1, ty2) = (* see H&S p208 *)
1793 :			if perform_type_checking then
1794 :			(case isComparable {ty1=ty1, ty2=ty2} of
1795 :			SOME ty => (ty, ty, signedNum Ast.INT)
1796 :			| NONE => (error
1797 :			"Type Error: bad types for arguments of \
1798 :			\comparison operator.";
1799 :			(ty1, ty2, signedNum Ast.INT)))
1800 :			else (ty1, ty2, signedNum Ast.INT)
1801 :
1802 :			fun logicalOp2(ty1, ty2) = (* And and Or *)
1803 :			let val stdInt = signedNum Ast.INT
1804 :			in if perform_type_checking then
1805 :			if isNumberOrPointer ty1
1806 :			andalso isNumberOrPointer ty2
1807 :			then (stdInt, stdInt, stdInt)
1808 :			else
1809 :			(error
1810 :			"Type Error: Unacceptable argument of logical operator.";
1811 :			(ty1, ty2, signedNum Ast.INT))
1812 :			else (ty1, ty2, signedNum Ast.INT)
1813 :			end
1814 :
1815 :			fun integralOp(ty1, ty2) =
1816 :			if perform_type_checking then
1817 :			if isIntegral ty1 andalso isIntegral ty2
1818 :			then (case usualBinaryCnv (ty1, ty2) of
1819 :			SOME ty => (ty, ty, ty)
1820 :			| NONE =>
1821 :			(bug "cnvExpression: integralOp.";
1822 :			(ty1, ty2, signedNum Ast.INT)))
1823 :			else
1824 :			(error
1825 :			"Type Error: arguments of mod, shift and \
1826 :			\bitwise operators must be integral numbers.";
1827 :			(ty1, ty2, signedNum Ast.INT))
1828 :			else (ty1, ty2, signedNum Ast.INT)
1829 :
1830 :			fun mulDivOp(ty1, ty2) =
1831 :			if perform_type_checking then
1832 :			if isNumber ty1
1833 :			andalso isNumber ty2
1834 :			then (case usualBinaryCnv (ty1, ty2) of
1835 :			SOME ty => (ty, ty, ty)
1836 :			| NONE =>
1837 :			(bug
1838 :			"usualBinaryCnv should \
1839 :			\succeed for numeric types.";
1840 :			(ty1, ty2, signedNum Ast.INT)))
1841 :			else
1842 :			(error
1843 :			"Type Error: arguments of mul and div must be numbers.";
1844 :			(ty1, ty2, signedNum Ast.INT))
1845 :			else
1846 :			(ty1, ty2, ty1)
1847 :
1848 :			in case expop
1849 :			of PT.Plus =>
1850 :			let val (ty1, expr1, ty2, expr2) = scalePlus(ty1, expr1, ty2, expr2)
1851 :			val resTy = plusOp(ty1, ty2)
1852 :			in
1853 :			mkBinopExp(resTy, expr1, expr2, Ast.Plus)
1854 :			end
1855 :			| PT.Minus =>
1856 :			let val (ty2, expr2) = scaleMinus(ty1, ty2, expr2)
1857 :			val resTy = minusOp(ty1, ty2)
1858 :			in
1859 :			mkBinopExp(resTy, expr1, expr2, Ast.Minus)
1860 :			end
1861 :			| PT.Times => mkBinopExp(mulDivOp(ty1, ty2), expr1, expr2, Ast.Times)
1862 :			| PT.Divide => mkBinopExp(mulDivOp(ty1, ty2), expr1, expr2, Ast.Divide)
1863 :			| PT.Mod => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Mod)
1864 :			| PT.Eq => mkBinopExp(eqOp(ty1, expr1, ty2, expr2), expr1, expr2, Ast.Eq)
1865 :			| PT.Neq => mkBinopExp(eqOp(ty1, expr1, ty2, expr2), expr1, expr2, Ast.Neq)
1866 :			| PT.Gt => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Gt)
1867 :			| PT.Lt => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Lt)
1868 :			| PT.Gte => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Gte)
1869 :			| PT.Lte => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Lte)
1870 :			| PT.And => mkBinopExp(logicalOp2(ty1, ty2), expr1, expr2, Ast.And)
1871 :			| PT.Or => mkBinopExp(logicalOp2(ty1, ty2), expr1, expr2, Ast.Or)
1872 :			| PT.BitOr => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitOr)
1873 :			| PT.BitAnd => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitAnd)
1874 :			| PT.BitXor => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitXor)
1875 :			| PT.Lshift => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Lshift)
1876 :			| PT.Rshift => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Rshift)
1877 :			| PT.PlusAssign => mkBinaryAssignOpExp(plusOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.PlusAssign, PT.Plus)
1878 :			| PT.MinusAssign => mkBinaryAssignOpExp(minusOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.MinusAssign, PT.Minus)
1879 :			| PT.TimesAssign => mkBinaryAssignOpExp(mulDivOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.TimesAssign, PT.Times)
1880 :			| PT.DivAssign => mkBinaryAssignOpExp(mulDivOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.DivAssign, PT.Divide)
1881 :			| PT.ModAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.ModAssign, PT.Mod)
1882 :			| PT.XorAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.XorAssign, PT.BitXor)
1883 :			| PT.OrAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.OrAssign, PT.BitOr)
1884 :			| PT.AndAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.AndAssign, PT.BitAnd)
1885 :			| PT.LshiftAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.LshiftAssign, PT.Lshift)
1886 :			| PT.RshiftAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.RshiftAssign, PT.Rshift)
1887 :			| PT.OperatorExt binop =>
1888 :			(bug "Operator extension (binop case) should be dealt with at top level case";
1889 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
1890 :
1891 :			| _ => (bug "[BuildAst.cnvExpression] \
1892 :			\Binary operator expected.";
1893 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
1894 :			end
1895 :
1896 :			fun processUnop(ty, expr, unop) =
1897 :			let fun simpleUnOp(expop, s) =
1898 :			let val newTy = usualUnaryCnv ty
1899 :			in if perform_type_checking then
1900 :			if isNumber newTy then ()
1901 :			else error ("Type Error: operand of " ^ s ^ " must be a number.")
1902 :			else ();
1903 :			mkUnopExp((ty, newTy), expr, expop)
1904 :			end
1905 :			fun logicalOp1 ty1 = (* Not *)
1906 :			let val stdInt = signedNum Ast.INT
1907 :			in if perform_type_checking then
1908 :			if isNumberOrPointer ty1
1909 :			then (stdInt, stdInt)
1910 :			else
1911 :			(error
1912 :			"Type Error: Unacceptable argument of logical operator.";
1913 :			(ty1, signedNum Ast.INT))
1914 :			else (ty1, signedNum Ast.INT)
1915 :			end
1916 :			in
1917 :			case unop of
1918 :			PT.PostInc => mkUnaryAssignOpExp(plusOp(ty, stdInt), ty, expr, {preOp=false}, Ast.PostInc, PT.Plus)
1919 :			| PT.PreInc => mkUnaryAssignOpExp(plusOp(ty, stdInt), ty, expr, {preOp=true}, Ast.PreInc, PT.Plus)
1920 :			| PT.PostDec => mkUnaryAssignOpExp(minusOp(ty, stdInt), ty, expr, {preOp=false}, Ast.PostDec, PT.Minus)
1921 :			| PT.PreDec => mkUnaryAssignOpExp(minusOp(ty, stdInt), ty, expr, {preOp=true}, Ast.PreDec, PT.Minus)
1922 :			| PT.Uplus => simpleUnOp(Ast.Uplus, "unary op +")
1923 :			| PT.Negate => simpleUnOp(Ast.Negate, "unary op +")
1924 :			| PT.Not => mkUnopExp(logicalOp1 ty, expr, Ast.Not)
1925 :			| PT.BitNot => simpleUnOp(Ast.BitNot, "unary op ~")
1926 :			| _ => (bug "BuildAst.cnvExpression \
1927 :			\Unary operator expected";
1928 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
1929 :			end
1930 :
1931 :			fun cnvExpr expr = (* returns (Ast.ctype * AST.CoreExpr) *)
1932 :			(case expr
1933 :			of PT.EmptyExpr =>
1934 :			(bug "cnvExpression: PT.EmptyExpr";
1935 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
1936 :			(* DBM: no more Ast.Empty_exp ??? *)
1937 :			| PT.MARKexpression(loc, expr) =>
1938 :			(pushLoc loc;
1939 :			cnvExpression expr
1940 :			before popLoc ())
1941 :			| PT.IntConst i =>
1942 :			wrapEXPR(signedNum Ast.INT, Ast.IntConst i)
1943 :			| PT.RealConst r =>
1944 :			wrapEXPR(signedNum Ast.DOUBLE, Ast.RealConst r)
1945 :			| PT.String s =>
1946 :			let val t = if (!default_signed_char)
1947 :			then signedNum Ast.CHAR
1948 :			else unsignedNum Ast.CHAR
1949 :			val ct = Ast.Pointer t
1950 :			in wrapEXPR(ct,Ast.StringConst s) end
1951 :			| PT.Id s =>
1952 :			(* should id of type function be immediately converted
1953 :			* to pointer to function? *)
1954 :			(case lookSym (Sym.object s)
1955 :			of SOME(ID(id as {ctype=ty,...})) =>
1956 :			wrapEXPR(ty, Ast.Id id)
1957 :			| SOME(MEMBER(member as {ctype=ty,kind,...})) =>
1958 :			(* could it be an enum constant? *)
1959 :			(* note: an enum const is inserted as EnumConst,
1960 :			* but is in same namespace as Object *)
1961 :			(case kind
1962 :			of Ast.ENUMmem i =>
1963 :			wrapEXPR(ty, Ast.EnumId(member,i))
1964 :			| Ast.STRUCTmem =>
1965 :			(error ("struct member used as id: " ^ s);
1966 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
1967 :			| Ast.UNIONmem =>
1968 :			(error ("union member used as id: " ^ s);
1969 :			wrapEXPR(Ast.Error, Ast.ErrorExpr)))
1970 :			| NONE => (* implicit declaration *)
1971 :			let val ty = signedNum Ast.INT
1972 :			val sym = Sym.object s
1973 :			val id = {name = sym, uid = Pid.new(), location = getLoc(),
1974 :			ctype = ty, stClass = Ast.DEFAULT, status = Ast.IMPLICIT,
1975 :			kind = Ast.NONFUN, global = topLevel()}
1976 :			in bindSym(sym, B.ID(id(*,B.OBJ{final=false}*)));
1977 :			(if undeclared_id_error then error else warn)
1978 :			(s ^ " not declared");
1979 :			wrapEXPR(ty, Ast.Id id)
1980 :			end
1981 :			| SOME binding =>
1982 :			(bug ("cnvExpression: bad id binding for "^s) ;
1983 :			debugPrBinding(s,binding);
1984 :			wrapEXPR(Ast.Error, Ast.ErrorExpr)))
1985 :
1986 :			| PT.Unop (PT.OperatorExt unop, expr) =>
1987 :			CNVUnop {unop=unop, argExpr=expr}
1988 :			| PT.Unop (PT.SizeofType typeName, _) =>
1989 :			let val ty = cnvCtype (false,typeName)
1990 :			in if storage_size_check then
1991 :			if hasKnownStorageSize ty then ()
1992 :			else error "Cannot take sizeof an expression of unknown size."
1993 :			else ();
1994 :			if !reduce_sizeof then
1995 :			let val ast = Ast.IntConst(sizeof ty)
1996 :			in wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
1997 :			ast)
1998 :			end
1999 :			else
2000 :			wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
2001 :			Ast.SizeOf ty)
2002 :			end
2003 :			| PT.Unop (expop, expr_parseTree) =>
2004 :			let val (ty, expr) = cnvExpression (expr_parseTree)
2005 :			(* ASSERT: expr_parseTree cannot be PT.EmptyExpr *)
2006 :			in case expop
2007 :			of PT.Sizeof =>
2008 :			(let fun checkForFun(PT.Id s) =
2009 :			(case lookSym (Sym.object s)
2010 :			of SOME(B.ID{ctype=Ast.Function _,...}) =>
2011 :			error "Cannot take sizeof a function."
2012 :			| _ => ())
2013 :			| checkForFun(PT.MARKexpression(loc, expr)) = checkForFun expr
2014 :			| checkForFun _ = ()
2015 :			in
2016 :			checkForFun expr_parseTree
2017 :			end;
2018 :			if storage_size_check then
2019 :			if hasKnownStorageSize ty then ()
2020 :			else error
2021 :			"Cannot take sizeof an expression of unknown size."
2022 :			else ();
2023 :			if !reduce_sizeof then
2024 :			let val ast = Ast.IntConst(sizeof ty)
2025 :			in
2026 :			wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED), ast)
2027 :			end
2028 :			else
2029 :			wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
2030 :			Ast.SizeOf ty)
2031 :			)
2032 :			| PT.AddrOf =>
2033 :			let val coreExpr = getCoreExpr expr
2034 :			val ty =
2035 :			if isLval(coreExpr, ty) then
2036 :			case coreExpr of
2037 :			Ast.Id {ctype=idCtype, stClass, ...} =>
2038 :			(if stClass = Ast.REGISTER
2039 :			then error "Cannot take address of register variable."
2040 :			else ();
2041 :			if isFunction idCtype then ty (* ty already pointer to fn *)
2042 :			else Ast.Pointer ty)
2043 :			| _ => Ast.Pointer ty
2044 :			else (error
2045 :			"Cannot take address of non-lval expression.";
2046 :			Ast.Pointer ty)
2047 :			in
2048 :			wrapEXPR(ty, Ast.AddrOf expr)
2049 :			end
2050 :
2051 :			(**** old code: delete in due course
2052 :			let fun checkId(PT.Id s) =
2053 :			(case getStorageClass (Sym.object s)
2054 :			of SOME Ast.REGISTER =>
2055 :			error
2056 :			"Cannot take address of register variable."
2057 :			| _ => ();
2058 :			if isFunction ty then
2059 :			(case ty
2060 :			of Ast.Pointer _ => wrapEXPR(ty, getCoreExpr expr)
2061 :			| _ => wrapEXPR(Ast.Pointer ty, getCoreExpr expr))
2062 :			(* Bug fix from Satish: 2/4/99
2063 :			It should be just "ty" in place of "Pointer ty", because we convert
2064 :			all function types to pointer types at the end of cnvExpr, by
2065 :			calling cnvFunctionToPointer2Function.
2066 :			Conservative coding: above deals with case when function may
2067 :			*not* have pointer around it.
2068 :			*)
2069 :			else wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr))
2070 :			| checkId(PT.MARKexpression(loc, expr)) = checkId expr
2071 :			| checkId _ = wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr)
2072 :			in
2073 :			checkId expr_parseTree
2074 :			end
2075 :			else
2076 :			(error
2077 :			"Cannot take address of non-lval expression.";
2078 :			wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr))
2079 :			end old code ******)
2080 :			| PT.Star => wrapEXPR(deref ty, Ast.Deref expr)
2081 :			(* Used to explicitly squash *f, but this is incorrect.
2082 :			Note 1: this happens automatically for type.
2083 :			If I have *f and f has type=pointer(function),
2084 :			then deref ty give us type=function,
2085 :			and then wrapEXPR gives us back pointer(function).
2086 :			Note 2: the real semantic processing of what star
2087 :			achieves operationally is defined in simplify. *)
2088 :			| PT.OperatorExt unop =>
2089 :			(bug "Operator extension (unop case) should be dealt with at top level case";
2090 :			wrapEXPR(Ast.Error, Ast.ErrorExpr))
2091 :
2092 :			| _ => processUnop(ty, expr, expop)
2093 :			end
2094 :
2095 :			| PT.Binop (PT.OperatorExt binop, expr1, expr2) =>
2096 :			CNVBinop {binop=binop,
2097 :			arg1Expr=expr1,
2098 :			arg2Expr=expr2}
2099 :			| PT.Binop (expop, expr1, expr2) =>
2100 :			let val (ty1, expr1') = cnvExpression (expr1)
2101 :			in case expop
2102 :			of PT.Dot =>
2103 :			let
2104 :			val s =
2105 :			let fun getId (PT.Id str) = str
2106 :			| getId (PT.MARKexpression(loc, expr)) = getId expr
2107 :			| getId _ = (error "Identifier expected - filling with missing_id";
2108 :			"<missing_id>")
2109 :			in
2110 :			getId expr2
2111 :			end
2112 :
2113 :			val m as {ctype,...} =
2114 :			(case isStructOrUnion ty1
2115 :			of SOME tid =>
2116 :			let val sym = Sym.member (tid, s)
2117 :			in case lookSym sym
2118 :			of SOME(MEMBER m) => m
2119 :			| _ =>
2120 :			(if isPartial tid then
2121 :			error
2122 :			"Can't access fields in incomplete type."
2123 :			else error ("Field " ^ s ^ " not found.");
2124 :			(* get garbage pid to continue *)
2125 :			bogusMember sym)
2126 :			end
2127 :			| NONE =>
2128 :			(error
2129 :			("Field " ^ s ^
2130 :			" not found; expression does not have structure \
2131 :			\or union type.");
2132 :			(* get garbage pid to continue *)
2133 :			bogusMember(Sym.member(bogusTid,"s"))))
2134 :			in wrapEXPR(ctype, Ast.Member (expr1', m))
2135 :			end
2136 :			| PT.Arrow =>
2137 :			let
2138 :			val s =
2139 :			let fun getId (PT.Id str) = str
2140 :			| getId (PT.MARKexpression(loc, expr)) = getId expr
2141 :			| getId _ = (error "Identifier expected - filling with missing_id";
2142 :			"<missing_id>")
2143 :			in
2144 :			getId expr2
2145 :			end
2146 :			val tyDeref = deref ty1
2147 :			val m as ({ctype,...}: Ast.member) =
2148 :			(case isStructOrUnion tyDeref
2149 :			of SOME tid =>
2150 :			let val sym = Sym.member (tid, s)
2151 :			in case lookSym sym
2152 :			of SOME(B.MEMBER m) => m
2153 :			| NONE =>
2154 :			(if isPartial tid then
2155 :			error
2156 :			"Can't access fields in incomplete type."
2157 :			else error ("Field " ^ s ^ " not found.");
2158 :			(* get garbage pid to continue *)
2159 :			bogusMember sym)
2160 :			| _ => (error (s^" is not a member");
2161 :			bogusMember sym)
2162 :			end
2163 :			| NONE =>
2164 :			(error
2165 :			("Field " ^ s ^
2166 :			" not found; expression does not have structure \
2167 :			\or union type.");
2168 :			(* get garbage pid to continue *)
2169 :			bogusMember(Sym.member(bogusTid,"s"))))
2170 :			in wrapEXPR(ctype, Ast.Arrow (expr1', m))
2171 :			end
2172 :			| PT.Sub =>
2173 :			let val (ty2, expr2') = cnvExpression (expr2)
2174 :			val ty =
2175 :			if isPointer ty1 then deref ty1
2176 :			else if isPointer ty2 then deref ty2
2177 :			else (error "Array/ptr expected.";
2178 :			Ast.Error)
2179 :			in wrapEXPR(ty, Ast.Sub (expr1', expr2'))
2180 :			end
2181 :			| PT.Comma =>
2182 :			let val (ty2, expr2') = cnvExpression (expr2)
2183 :			in wrapEXPR(ty2, Ast.Comma (expr1', expr2'))
2184 :			end
2185 :			| PT.Assign =>
2186 :			let val (exprTy, expr2') = cnvExpression (expr2)
2187 :			val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1',
2188 :			rhsTy=exprTy,
2189 :			rhsExprOpt=SOME(getCoreExpr expr2')}
2190 :			val resultTy = getCoreType ty1
2191 :			val (expr2') = wrapCast (resultTy, expr2')
2192 :			in wrapEXPR(resultTy, Ast.Assign (expr1', expr2'))
2193 :			(* type of result is the unqualified type of the left
2194 :			* operand: H&S p 221. *)
2195 :			end
2196 :			| _ => let val (ty2, expr2') = cnvExpression (expr2)
2197 :			in processBinop (ty1, expr1', ty2, expr2', expop)
2198 :			end
2199 :			end
2200 :			| PT.QuestionColon (expr1, expr2, expr3) =>
2201 :			let
2202 :			val (exprTy, expr1') = cnvExpression (expr1)
2203 :			val _ =
2204 :			if perform_type_checking andalso not(isScalar exprTy)
2205 :			then error
2206 :			"Type Error: condition of question-colon statement is not scalar."
2207 :			else ()
2208 :			val (ty2, expr2') = cnvExpression (expr2)
2209 :			val (ty3, expr3') = cnvExpression (expr3)
2210 :			val ty4 = (case conditionalExp {ty1=ty2,exp1Zero=isZeroExp expr2',
2211 :			ty2=ty3,exp2Zero=isZeroExp expr3'}
2212 :			of SOME ty => ty
2213 :			| NONE =>
2214 :			(error
2215 :			"Type Error: Unacceptable operands of question-colon.";
2216 :			ty2))
2217 :			val (expr2') = wrapCast (ty4, expr2')
2218 :			val (expr3') = wrapCast (ty4, expr3')
2219 :			in
2220 :			wrapEXPR(ty4, Ast.QuestionColon (expr1',expr2',expr3'))
2221 :			end
2222 :			| PT.Call (expr, exprs) =>
2223 :			let
2224 :			val (funTy, expr', prototype) =
2225 :			let fun checkId (PT.Id s) =
2226 :			let val funId as ({ctype=funTy,...}: Ast.id) =
2227 :			(case lookSym (Sym.func s)
2228 :			of SOME(ID id) => id
2229 :			| NONE =>
2230 :			(* if ANSI C then this should be an error... *)
2231 :			let val ty = mkFunctionCt (signedNum Ast.INT,[])
2232 :			val varSym = Sym.object s
2233 :			val id = {name = varSym, uid = Pid.new(),
2234 :			location = getLoc(),status=Ast.IMPLICIT,
2235 :			ctype = ty, stClass = Ast.EXTERN,
2236 :			kind = Ast.FUNCTION{hasFunctionDef=false},
2237 :			global = true} (* is is a function, so it is global! *)
2238 :			val binding = ID id
2239 :			in (* force insertion of symbol at top level *)
2240 :			bindSymGlobal(varSym, binding);
2241 :			(if Config.TypeCheckControl.undeclared_fun_error
2242 :			then error else warn)
2243 :			("function " ^ s ^ " not declared");
2244 :			id
2245 :			end
2246 :			| _ => (error (s^" is not a function");
2247 :			{name = Sym.func s, uid = Pid.new(),
2248 :			location = SourceMap.UNKNOWN,
2249 :			ctype = Ast.Error, global = topLevel(),
2250 :			stClass = Ast.DEFAULT, status = Ast.IMPLICIT,
2251 :			kind = Ast.FUNCTION{hasFunctionDef=false}}))
2252 :			val adorn = bindAid funTy
2253 :			in (funTy, Ast.EXPR (Ast.Id funId, adorn, getLoc()),
2254 :			isFunctionPrototype funTy)
2255 :			end
2256 :			| checkId(PT.MARKexpression(loc, expr)) =
2257 :			(pushLoc loc;
2258 :			checkId expr
2259 :			before popLoc ())
2260 :			| checkId _ =
2261 :			let val (funTy, expr) = cnvExpression expr
2262 :			val prototype = isFunctionPrototype funTy
2263 :			in (funTy, expr, prototype)
2264 :			end
2265 :			in
2266 :			checkId expr
2267 :			end
2268 :
2269 :			val tyExprList = List.map cnvExpression exprs
2270 :			val (argTys, exprs) = ListPair.unzip tyExprList
2271 :
2272 :			fun cnvArgs (expr :: exprs, ty :: tys) =
2273 :			let val (expr) = wrapCast (ty, expr)
2274 :			val (exprs) = cnvArgs (exprs, tys)
2275 :			in expr :: exprs
2276 :			end
2277 :			| cnvArgs (nil, nil) = nil
2278 :			| cnvArgs _ =
2279 :			(bug "type list and expression list must be same size";
2280 :			nil)
2281 :
2282 :			val (retTy, exprs) =
2283 :			if perform_type_checking
2284 :			then if prototype
2285 :			then let val (retTy, cnvArgTys) =
2286 :			checkFn (funTy, argTys, exprs)
2287 :			val (exprs) = cnvArgs (exprs, cnvArgTys)
2288 :			in (retTy, exprs)
2289 :			end
2290 :			else let val cnvArgTys = List.map (functionArgConv) argTys
2291 :			val retTy =
2292 :			case getFunction funTy
2293 :			of SOME(retTy,_) => retTy
2294 :			| NONE =>
2295 :			(error
2296 :			"Called object is not a function.";
2297 :			Ast.Error)
2298 :			val (exprs) = cnvArgs (exprs, cnvArgTys)
2299 :			in (retTy, exprs)
2300 :			end
2301 :			else let val retTy = case getFunction funTy
2302 :			of SOME(retTy,_) => retTy
2303 :			| NONE => Ast.Void
2304 :			in (retTy, exprs)
2305 :			end
2306 :			in
2307 :			wrapEXPR(retTy, Ast.Call(expr', exprs))
2308 :			end
2309 :			| PT.Cast (ct, expr) => (* TODO: should check consistency of cast *)
2310 :			let val ty = cnvCtype (false, ct)
2311 :			val (_, expr') = cnvExpression expr
2312 :			in wrapEXPR(ty, Ast.Cast (ty, expr'))
2313 :			end
2314 :			| PT.InitList exprs =>
2315 :			let fun process e = #2(cnvExpression e)
2316 :			val exprs = List.map process exprs
2317 :			in (* PT.InitList should only occur within declarators as
2318 :			* an aggregate initializer. It is handled in processDecr. *)
2319 :			bug "cnvExpression: unexpected InitList";
2320 :			wrapEXPR(Ast.Error, Ast.ErrorExpr)
2321 :			end
2322 :
2323 :			| PT.ExprExt expr => CNVExp expr
2324 :			)
2325 :			in cnvExpr expr
2326 :			end
2327 :
2328 :			(* --------------------------------------------------------------------
2329 :			* cnvType : bool * PT.ctype -> Ast.ctype
2330 :			*
2331 :			* Converts a parse-tree type into an ast type, adding new type and
2332 :			* symbol (e.g. enumerated values and field identifiers) into the
2333 :			* environment.
2334 :			*
2335 :			* The boolean first argument is a flag indicating if this type is a
2336 :			* `shadow' - that is a struct/enum/union tag type used to refer
2337 :			* to a future struct/union/enum declaration rather than one defined in
2338 :			* an outer scope.
2339 :			*
2340 :			* Named types (i.e. structs/unions/enums/typedefs) are represented by
2341 :			* indexes into the named-type table. That table maps these indexes to
2342 :			* the actual struct/union/enum/typedef. This allows for for such a
2343 :			* type to be resolved without having to do multiple enquiries into the
2344 :			* symbol-table stack. By convention, an explicitly tagged type will be
2345 :			* stored redundantly in the symbol table: once as its explicit tag and
2346 :			* once as a manufactured one corresponding to the unique named type id
2347 :			* generated by Tidtab.new.
2348 :			* -------------------------------------------------------------------- *)
2349 :
2350 :			and cnvCtype (isShadow: bool, ty: PT.ctype) : Ast.ctype =
2351 :			let fun cnvSpecifier specifiers =
2352 :			let val signed = ref (NONE : Ast.signedness option)
2353 :			val frac = ref (NONE : Ast.fractionality option)
2354 :			val sat = ref (NONE : Ast.saturatedness option)
2355 :			val kind = ref (NONE : Ast.intKind option)
2356 :			fun cnvSpecList (spec :: specL) =
2357 :			(case spec
2358 :			of PT.Signed =>
2359 :			(case !kind
2360 :			of SOME (Ast.FLOAT | Ast.DOUBLE | Ast.LONGDOUBLE) =>
2361 :			error "illegal combination of signed with float/double/long double"
2362 :			| _ => ();
2363 :			case !signed
2364 :			of NONE => (signed := SOME Ast.SIGNED)
2365 :			| SOME _ => error "Multiple signed/unsigned")
2366 :			| PT.Unsigned =>
2367 :			(case !kind
2368 :			of SOME (Ast.FLOAT | Ast.DOUBLE | Ast.LONGDOUBLE) =>
2369 :			error "illegal combination of unsigned with float/double/long double"
2370 :			| _ => ();
2371 :			case !signed
2372 :			of NONE => (signed := SOME Ast.UNSIGNED)
2373 :			| SOME _ => error "Multiple signed/unsigned")
2374 :			| PT.Char =>
2375 :			(case !kind
2376 :			of NONE => (kind := SOME Ast.CHAR)
2377 :			| SOME ct =>
2378 :			error (case ct
2379 :			of Ast.CHAR => "duplicate char specifier"
2380 :			| _ => "illegal use of char specifier"))
2381 :			| PT.Short =>
2382 :			(case !kind
2383 :			of (NONE | SOME Ast.INT) => (kind := SOME Ast.SHORT)
2384 :			| SOME ct =>
2385 :			error (case ct
2386 :			of Ast.SHORT => "duplicate short specifier"
2387 :			| _ => "illegal use of short specifier"))
2388 :			| PT.Int =>
2389 :			(case !kind
2390 :			of NONE => (kind := SOME Ast.INT)
2391 :			| SOME (Ast.SHORT | Ast.LONG | Ast.LONGLONG) => ()
2392 :			| SOME ct =>
2393 :			error (case ct
2394 :			of Ast.INT => "duplicate int specifier"
2395 :			| _ => "illegal use of int specifier"))
2396 :			| PT.Long =>
2397 :			(case !kind
2398 :			of NONE => (kind := SOME Ast.LONG)
2399 :			| SOME Ast.LONG => (kind := SOME Ast.LONGLONG)
2400 :			| SOME Ast.INT => (kind := SOME Ast.LONG)
2401 :			| SOME ct =>
2402 :			error (case ct
2403 :			of Ast.LONGLONG => "triplicate long specifier"
2404 :			| _ => "illegal use of long specifier"))
2405 :			| PT.Float =>
2406 :			(case !signed
2407 :			of NONE => ()
2408 :			| SOME _ => error "illegal combination of signed/unsigned with float";
2409 :			case !kind
2410 :			of NONE => (kind := SOME Ast.FLOAT)
2411 :			| SOME ct =>
2412 :			error (case ct
2413 :			of Ast.FLOAT => "duplicate float specifier"
2414 :			| _ => "illegal use of float specifier"))
2415 :			| PT.Double =>
2416 :			(case !signed
2417 :			of NONE => ()
2418 :			| SOME _ => error "illegal combination of signed/unsigned with double";
2419 :			case !kind
2420 :			of NONE => (kind := SOME Ast.DOUBLE)
2421 :			| SOME Ast.LONG => (kind := SOME Ast.LONGDOUBLE)
2422 :			| SOME ct =>
2423 :			error (case ct
2424 :			of Ast.DOUBLE => "duplicate double specifier"
2425 :			| _ => "illegal use of double specifier"))
2426 :			| PT.Fractional =>
2427 :			(case !frac
2428 :			of NONE => (frac := SOME Ast.FRACTIONAL)
2429 :			| SOME _ => error "Multiple fractional or wholenum")
2430 :			| PT.Wholenum =>
2431 :			(case !frac
2432 :			of NONE => (frac := SOME Ast.WHOLENUM)
2433 :			| SOME _ => error "Multiple fractional or wholenum")
2434 :			| PT.Saturate =>
2435 :			(case !sat
2436 :			of NONE => (sat := SOME Ast.SATURATE)
2437 :			| SOME _ => error "Multiple saturate or nonsaturate")
2438 :			| PT.Nonsaturate =>
2439 :			(case !sat
2440 :			of NONE => (sat := SOME Ast.NONSATURATE)
2441 :			| SOME _ => error "Multiple saturate or nonsaturate")
2442 :			| _ => error("Illegal combination of type specifiers.");
2443 :			cnvSpecList specL)
2444 :			| cnvSpecList [] =
2445 :			let val numKind = case !kind
2446 :			of NONE => Ast.INT
2447 :			| SOME numKind => numKind
2448 :			val frac = case !frac
2449 :			of NONE => Ast.WHOLENUM
2450 :			| SOME frac => frac
2451 :			val (sign,decl)
2452 :			= case (!signed, numKind)
2453 :			of (NONE, Ast.CHAR) =>
2454 :			if (!default_signed_char)
2455 :			then (Ast.SIGNED, Ast.SIGNASSUMED)
2456 :			else (Ast.UNSIGNED, Ast.SIGNASSUMED)
2457 :			(* according to H&S p115,
2458 :			* char can be signed or unsigned *)
2459 :			| (NONE, _) => (Ast.SIGNED, Ast.SIGNASSUMED)
2460 :			| (SOME sign, _) => (sign, Ast.SIGNDECLARED)
2461 :			val sat = case !sat
2462 :			of NONE => Ast.NONSATURATE
2463 :			| SOME sat => sat
2464 :			in
2465 :			Ast.Numeric (sat,frac,sign,numKind,decl)
2466 :			end
2467 :			fun noMore [] _ = ()
2468 :			| noMore _ err = error (err ^ " cannot be combined with a specifier.")
2469 :			in case specifiers
2470 :			(* singleton cases: these should appear solo *)
2471 :			of PT.Void :: l => (noMore l "Void"; Ast.Void)
2472 :			| PT.Ellipses :: l => (noMore l "Ellipse"; Ast.Ellipses)
2473 :			| (PT.Array (expr, ty)) :: l =>
2474 :			let val _ = noMore l "Array"
2475 :			val opt = case expr of
2476 :			PT.EmptyExpr => NONE
2477 :			| _ => (case evalExpr expr of (* cannot be EmptyExpr *)
2478 :			(SOME i, _, expr', _) =>
2479 :			(if i=0 then warn "Array has zero size." else ();
2480 :			SOME(i, expr'))
2481 :			| (NONE, _, expr', _) => (error "Array size must be constant expression.";
2482 :			SOME(0, expr')))
2483 :			val ty' = cnvCtype (false, ty)
2484 :			in Ast.Array (opt, ty')
2485 :			end
2486 :			| (PT.Pointer ty) :: l =>
2487 :			let val _ = noMore l "Pointer"
2488 :			val ty' = cnvCtype (false, ty)
2489 :			in Ast.Pointer ty'
2490 :			end
2491 :			| (PT.Function {retType,params}) :: l =>
2492 :			let val _ = noMore l "Function"
2493 :			val retTy = cnvCtype (false, retType)
2494 :			fun process (dt, decl) =
2495 :			let
2496 :			(*dpo: ignore storage class in translating type *)
2497 :			val ty = (dt2ct o #1) (processDeclarator (dt, decl))
2498 :			val ty = cnvCtype (false, ty)
2499 :			in
2500 :			ty
2501 :			end
2502 :			val argTys = List.map process params
2503 :			in mkFunctionCt (retTy, argTys)
2504 :			end
2505 :
2506 :			(* ------------- Enumerated Types ----------------
2507 :			* If enum tag is explicitly mentioned:
2508 :			* if partially defined then use that named type
2509 :			* identifier;
2510 :			* otherwise, if it has never been mentioned or if
2511 :			* it has been mentioned for a completely defined
2512 :			* type (so that this definition is new for an
2513 :			* inner scope) then create a new named type id
2514 :			* and store a reference to it in the current
2515 :			* symbol table.
2516 :			* Otherwise, this is an `anonynmous' enum type: create a
2517 :			* new named type id and store a reference to it in the
2518 :			* current symbol table.
2519 :			*)
2520 :
2521 :			| (PT.Enum {tagOpt,enumerators,trailingComma}) :: l =>
2522 :			let
2523 :			val _ = noMore l "Enum"
2524 :			(* check for trailing comma warning/error *)
2525 :			val _ =
2526 :			if trailingComma then
2527 :			if #error Config.ParseControl.trailingCommaInEnum
2528 :			then error "trailing comma in enum declaration"
2529 :			else if #warning Config.ParseControl.trailingCommaInEnum
2530 :			then warn "trailing comma in enum declaration"
2531 :			else ()
2532 :			else ()
2533 :			val (tid, alreadyDefined) =
2534 :			(* alreadyDefined for multi-file analysis mode *)
2535 :			(case tagOpt
2536 :			of SOME tagname =>
2537 :			let
2538 :			val sym = Sym.tag tagname
2539 :			val tidFlagOpt =
2540 :			(case lookLocalScope sym
2541 :			of SOME(TAG{ctype=ty,location=loc',...}) =>
2542 :			(case ty
2543 :			of Ast.EnumRef tid =>
2544 :			if isPartial tid
2545 :			then SOME{tid=tid, alreadyDefined=false}
2546 :			else if repeated_declarations_ok
2547 :			then SOME{tid=tid, alreadyDefined=true}
2548 :			else
2549 :			(error
2550 :			("Redeclaration of enum tag `" ^
2551 :			tagname ^
2552 :			"'; previous declaration at " ^
2553 :			SM.locToString loc');
2554 :			NONE)
2555 :			| _ =>
2556 :			(error
2557 :			("Redeclaration of enum tag `" ^
2558 :			tagname ^
2559 :			"'; previous declaration was not an " ^
2560 :			"enum tag and appeared at " ^
2561 :			SM.locToString loc');
2562 :			NONE))
2563 :			| NONE => NONE
2564 :			| _ => (error (tagname^ " is not an enum tag");
2565 :			NONE))
2566 :			in case tidFlagOpt
2567 :			of SOME{tid, alreadyDefined} =>
2568 :			(tid, alreadyDefined)
2569 :			| NONE =>
2570 :			let val tid = Tid.new ()
2571 :			val ty = Ast.EnumRef tid
2572 :			in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2573 :			location=getLoc(), ctype=ty});
2574 :			bindTid (tid, {name=tagOpt, ntype=NONE,
2575 :			global=topLevel(), location=getLoc()});
2576 :			(tid, false)
2577 :			end
2578 :			end
2579 :			| NONE =>
2580 :			let val (tid,alreadyDefined) =
2581 :			if !multi_file_mode andalso (topLevel ()) then
2582 :			(* in multi_file_mode, give identical top-level
2583 :			* enums the same tid *)
2584 :			case AnonymousStructs.findAnonStructEnum ty
2585 :			of SOME tid => (tid,true)
2586 :			| NONE =>
2587 :			let val tid = Tid.new ()
2588 :			in AnonymousStructs.addAnonTid(ty, tid);
2589 :			(tid,false)
2590 :			end
2591 :			else
2592 :			let val tid = Tid.new ()
2593 :			(* in standard mode, allocate new tid *)
2594 :			in (tid, false)
2595 :			end
2596 :			in if alreadyDefined then ()
2597 :			else bindTid (tid, {name=tagOpt, ntype=NONE,
2598 :			global=topLevel(), location=getLoc()});
2599 :			(tid, alreadyDefined)
2600 :			end)
2601 :
2602 :			(* add each enum value into symbol table (and evaluate it);
2603 :			prevVal passes the enum value from one enum entry to the next
2604 :			so that
2605 :			enum {e1,e2,e3=4,e4};
2606 :			gives
2607 :			enum {e1=0,e2=1,e3=4,e4=5};
2608 :			*)
2609 :			fun process prevVal nil = nil
2610 :			| process prevVal ((name,e) :: l) =
2611 :			let val constValOpt =
2612 :			case e of
2613 :			PT.EmptyExpr => NONE
2614 :			| _ => (case evalExpr e of
2615 :			(SOME i, _, _, sizeofFl) =>
2616 :			(if sizeofFl andalso not(!reduce_sizeof)
2617 :			then warn("sizeof in enum value " ^
2618 :			"not preserved in source-to-source mode.")
2619 :			else ();
2620 :			SOME i)
2621 :			| (NONE, _, _, _) =>
2622 :			(error "Enum value must be constant expression.";
2623 :			NONE))
2624 :			val constVal =
2625 :			case constValOpt
2626 :			of SOME n => n
2627 :			| NONE => prevVal + 1
2628 :			val sym = Sym.enumConst name
2629 :			val ty = Ast.EnumRef tid
2630 :			val _ = checkNonIdRebinding(sym, ty, "enum constant ")
2631 :
2632 :			val member = {name = sym, uid = Pid.new(),
2633 :			location = getLoc(), ctype=ty,
2634 :			kind = Ast.ENUMmem constVal}
2635 :			val binding = B.MEMBER member
2636 :
2637 :			val _ = bindSym (sym, binding)
2638 :			in
2639 :			(member, constVal) :: (process constVal l)
2640 :			end
2641 :			in if alreadyDefined then ()
2642 :			else
2643 :			let val idIntList = process (LargeInt.fromInt ~1) enumerators
2644 :			val namedTy = B.Enum (tid,idIntList)
2645 :			in bindTid (tid, {name=tagOpt, ntype=SOME namedTy,
2646 :			global=topLevel(), location=getLoc()});
2647 :			pushTids tid
2648 :			end;
2649 :			Ast.EnumRef tid
2650 :			end
2651 :
2652 :
2653 :			(* ------------- Structs and Unions ----------------
2654 :			* Very similar to rules for converting enums. *)
2655 :			| (PT.Struct {isStruct, tagOpt, members}) :: l =>
2656 :			let val _ = noMore l "Struct"
2657 :			val (tid, alreadyDefined) =
2658 :			(case tagOpt
2659 :			of SOME tagname =>
2660 :			let
2661 :			val sym = Sym.tag tagname
2662 :			val tidFlagOpt =
2663 :			(case lookLocalScope sym
2664 :			of SOME(TAG{ctype=ty,location=loc',...}) =>
2665 :			(case ty
2666 :			of (Ast.UnionRef tid | Ast.StructRef tid) =>
2667 :			if isPartial tid
2668 :			then SOME{tid=tid, alreadyDefined=false}
2669 :			else if repeated_declarations_ok
2670 :			then SOME{tid=tid, alreadyDefined=true}
2671 :			else (error("Redeclaration of type tag `"
2672 :			^ tagname
2673 :			^ "'; previous declaration at "
2674 :			^ SM.locToString loc');
2675 :			NONE)
2676 :			| _ =>
2677 :			(error("Redeclaration of type tag `"
2678 :			^ tagname ^
2679 :			"'; previous declaration was not a "
2680 :			^ "type tag and appeared at "
2681 :			^ SM.locToString loc');
2682 :			NONE))
2683 :			| NONE => NONE
2684 :			| _ => (bug "cnvExpression: tag symbol 2"; NONE))
2685 :			in case tidFlagOpt
2686 :			of SOME{tid, alreadyDefined} =>
2687 :			(tid, alreadyDefined)
2688 :			| NONE => (* create a partial tid *)
2689 :			let val tid = Tid.new ()
2690 :			val ty = if isStruct then Ast.StructRef tid
2691 :			else Ast.UnionRef tid
2692 :			in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2693 :			location=getLoc(),
2694 :			ctype=ty});
2695 :			bindTid(tid, {name=NONE, ntype=NONE,
2696 :			global=topLevel(), location=getLoc()});
2697 :			(tid, false)
2698 :			end
2699 :			end
2700 :			| NONE =>
2701 :			let
2702 :			val (tid,alreadyDefined) =
2703 :			if !multi_file_mode andalso (topLevel ()) then
2704 :			(* in multi_file_mode, give identical top-level
2705 :			* structs the same tid
2706 :			*)
2707 :			case AnonymousStructs.findAnonStructEnum ty
2708 :			of SOME tid => (tid, true)
2709 :			| NONE =>
2710 :			let val tid = Tid.new ()
2711 :			in AnonymousStructs.addAnonTid(ty, tid);
2712 :			(tid, false)
2713 :			end
2714 :			else
2715 :			let val tid = Tid.new ()
2716 :			in (tid,false)
2717 :			end
2718 :			in if alreadyDefined then ()
2719 :			else bindTid (tid, {name=NONE, ntype=NONE,
2720 :			global=topLevel(), location=getLoc()});
2721 :			(tid, alreadyDefined)
2722 :			end)
2723 :
2724 :			(* add members to symbol table, evaluate bit fields
2725 :			* when present *)
2726 :			fun process1 (ct, declExprs) =
2727 :			let
2728 :			val ty = cnvCtype (false, ct)
2729 :			fun process2 (decr,expr)
2730 :			: Ast.ctype * Ast.member option * Int32.int option =
2731 :			let
2732 :	dbm	639	val (ty', memNameOpt, loc) = mungeTyDecr (ty, decr)
2733 :	dbm	597	val sizeOpt =
2734 :			case expr of
2735 :			PT.EmptyExpr => NONE
2736 :			| _ => (case evalExpr expr of
2737 :			(SOME i, _, _, false) => SOME i
2738 :			| (SOME i, _, _, true) =>
2739 :			(if !reduce_sizeof then ()
2740 :			else warn ("sizeof in bitfield specification " ^
2741 :			"not preserved in source-to-source mode");
2742 :			SOME i)
2743 :			| (NONE, _, _, _) =>
2744 :			(error "Bitfield size must be constant expression";
2745 :			NONE))
2746 :			val memberOpt : Ast.member option =
2747 :			(case memNameOpt
2748 :			of SOME id' =>
2749 :			let val sym = Sym.member (tid,id')
2750 :			val _ =
2751 :			checkNonIdRebinding(sym, ty',
2752 :			"struct/union member ");
2753 :			val _ =
2754 :			if isPartialTy ty'
2755 :			then error("Member `" ^ id'
2756 :			^ "' has incomplete type.")
2757 :			else ();
2758 :			val _ =
2759 :			if isNonPointerFunction ty'
2760 :			then error("Member `" ^ id'
2761 :			^ "' has function type.")
2762 :			else ();
2763 :			val member = {name = sym,
2764 :			uid = Pid.new(),
2765 :	dbm	639	location = loc,
2766 :	dbm	597	ctype = ty',
2767 :			kind = if isStruct
2768 :			then Ast.STRUCTmem
2769 :			else Ast.UNIONmem}
2770 :			in bindSym(sym,MEMBER member);
2771 :			SOME member
2772 :			(* DBM: FIELDs? *)
2773 :			end
2774 :			| NONE => NONE)
2775 :			in (ty', memberOpt, sizeOpt)
2776 :			end (* fun process2 *)
2777 :			in map process2 declExprs
2778 :			end (* fun process1 *)
2779 :
2780 :			(* union members are more restricted than struct members *)
2781 :			fun checkUnionMember (ty: Ast.ctype, NONE: Ast.member option,
2782 :			_ : Int32.int option) =
2783 :			(error "union member has no name";
2784 :			(ty,bogusMember(Sym.member(tid,"<noname>"))))
2785 :			| checkUnionMember (ty,SOME m,SOME _) =
2786 :			(error "union member has size spec";
2787 :			(ty,m))
2788 :			| checkUnionMember (ty,SOME m,NONE) = (ty,m)
2789 :
2790 :			in if alreadyDefined then ()
2791 :			else
2792 :			let val members = List.map process1 members
2793 :			val members = List.concat members
2794 :			val namedTy =
2795 :			if isStruct then B.Struct(tid, members)
2796 :			else B.Union(tid, map checkUnionMember members)
2797 :			val binding : B.tidBinding =
2798 :			{name = tagOpt, ntype = SOME namedTy,
2799 :			global = topLevel(), location = getLoc()}
2800 :			in bindTid (tid, binding);
2801 :			pushTids tid
2802 :			end;
2803 :			(if isStruct then Ast.StructRef else Ast.UnionRef) tid
2804 :			end
2805 :
2806 :			| (PT.TypedefName s) :: l =>
2807 :			(* type symbol is added at the point of declaration: see
2808 :			* cnvExternalDecl (case ExternalDecl(TypeDecl) and cnvStatement (case
2809 :			* Decl(TypeDecl) *)
2810 :			(noMore l "Typedef";
2811 :			case lookSym (Sym.typedef s)
2812 :			of SOME(TYPEDEF{ctype,...}) => ctype
2813 :			| _ => (error("typedef " ^ s ^ " has not been defined.");
2814 :			Ast.Error))
2815 :
2816 :			| (PT.StructTag {isStruct,name=s}) :: l =>
2817 :			let val _ = noMore l "Struct"
2818 :			val sym = Sym.tag s
2819 :			val tyOpt =
2820 :			case lookSym sym
2821 :			of SOME(TAG{ctype,...}) => SOME ctype
2822 :			| NONE => NONE
2823 :			| _ => (bug "cnvExpression: bad tag 3"; NONE)
2824 :			in if not (isSome tyOpt) orelse
2825 :			(isShadow andalso not (isLocalScope sym)) then
2826 :			let val tid = Tid.new ()
2827 :			val ty = (if isStruct then Ast.StructRef else Ast.UnionRef) tid
2828 :			in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2829 :			location=getLoc(), ctype=ty});
2830 :			bindTid (tid, {name=SOME s, ntype=NONE,
2831 :			global=topLevel(), location=getLoc()});
2832 :			ty
2833 :			end
2834 :			else valOf tyOpt (* guaranteed to be SOME *)
2835 :			end
2836 :
2837 :			| (PT.EnumTag s) :: l => (* nearly idenitical to struct tag case *)
2838 :			let val _ = noMore l "Enum"
2839 :			val sym = Sym.tag s
2840 :			val tyOpt =
2841 :			case lookSym sym
2842 :			of SOME(TAG{ctype,...}) => SOME ctype
2843 :			| NONE => (if TypeCheckControl.partial_enum_error
2844 :			then error("incomplete enum " ^ s)
2845 :			else ();
2846 :			NONE)
2847 :			| _ => (bug "cnvExpression: bad tag 3"; NONE)
2848 :			in if not (isSome tyOpt) orelse
2849 :			(isShadow andalso not (isLocalScope sym)) then
2850 :			(* if this is explicitly a shadow or a enum tag not seen
2851 :			* before then create a new named type identifier and
2852 :			* record that this type is partially (incompletely)
2853 :			* defined *)
2854 :			let val tid = Tid.new ()
2855 :			val ty = Ast.EnumRef tid
2856 :			in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2857 :			location=getLoc(), ctype=ty});
2858 :			bindTid (tid, {name=SOME s, ntype=NONE,
2859 :			global=topLevel(), location=getLoc()});
2860 :			ty
2861 :			end
2862 :			(* otherwise return the type already established in
2863 :			* environment *)
2864 :			else valOf tyOpt
2865 :			end
2866 :
2867 :			| (PT.SpecExt xspec) :: rest =>
2868 :			CNVSpecifier {isShadow=isShadow, rest=rest} xspec
2869 :			| l => cnvSpecList l
2870 :			end
2871 :
2872 :			val {qualifiers, specifiers} = ty
2873 :			in cnvQualifiers (cnvSpecifier specifiers) qualifiers
2874 :			end
2875 :
2876 :			and cnvType (isShadow: bool, {storage,qualifiers,specifiers}: PT.decltype)
2877 :			: Ast.ctype * Ast.storageClass =
2878 :			let val sc = cnvStorage storage
2879 :			val ct = cnvCtype (isShadow,{qualifiers=qualifiers,specifiers=specifiers})
2880 :			in (ct,sc)
2881 :			end
2882 :
2883 :			and cnvQualifiers ty [] = ty
2884 :			| cnvQualifiers ty [PT.CONST] = Ast.Qual (Ast.CONST, ty)
2885 :			| cnvQualifiers ty [PT.VOLATILE] = Ast.Qual (Ast.VOLATILE, ty)
2886 :			| cnvQualifiers ty (PT.VOLATILE :: PT.VOLATILE :: _) =
2887 :			(error "Duplicate `volatile'."; ty)
2888 :			| cnvQualifiers ty (PT.CONST :: PT.CONST :: _) =
2889 :			(error "Duplicate 'const'."; ty)
2890 :			| cnvQualifiers ty (_ :: _ :: _ :: _) =
2891 :			(error "too many 'const/volatile' qualifiers."; ty)
2892 :			(* See: ISO-C Standard, p. 64 for meaning of const volatile. *)
2893 :			| cnvQualifiers ty (_ :: _ :: nil) = ty
2894 :
2895 :
2896 :
2897 :			(* --------------------------------------------------------------------
2898 :			* cnvStorage : PT.storage list -> Ast.storageClass option
2899 :			*
2900 :			* Converts a parse-tree storage class into an ast storage class. The
2901 :			* only subtlety is the case where no parse-tree storage class has been
2902 :			* given in which case the default (supplied by second argument) ast
2903 :			* storage class is used.
2904 :			*
2905 :			* For rules for storage classes, see K&R A8.1
2906 :			* -------------------------------------------------------------------- *)
2907 :
2908 :			and cnvStorage [] = Ast.DEFAULT
2909 :			| cnvStorage [PT.STATIC] = Ast.STATIC
2910 :			| cnvStorage [PT.EXTERN] = Ast.EXTERN
2911 :			| cnvStorage [PT.REGISTER] = Ast.REGISTER
2912 :			| cnvStorage [PT.AUTO] = Ast.AUTO
2913 :			| cnvStorage [PT.TYPEDEF] =
2914 :			(error "illegal use of TYPEDEF";
2915 :			Ast.DEFAULT)
2916 :			| cnvStorage _ =
2917 :			(error "Declarations can contain at most one storage class\
2918 :			\ (static, extern, register, auto).";
2919 :			Ast.DEFAULT)
2920 :
2921 :			(* --------------------------------------------------------------------
2922 :			* evalExpr : ParseTree expr -> int option
2923 :			*
2924 :			* Converts parse-tree expressions to integer constants where possible;
2925 :			* NONE used for cases where no constant can be computed or when no
2926 :			* expression is given. A new environment is returned because it is
2927 :			* possible to embed definitions of struct/union/enum types within
2928 :			* sizeofs and casts.
2929 :			* -------------------------------------------------------------------- *)
2930 :
2931 :			and evalExpr e = (* evalExpr should not be called with PT.EmptyExpr *)
2932 :			let
2933 :			val encounteredSizeof = ref false
2934 :			val (eTy, e') = cnvExpression (e)
2935 :			fun evalAstExpr (Ast.EXPR (coreExpr,adorn, _)) =
2936 :			case coreExpr
2937 :			of Ast.IntConst i => SOME i
2938 :			| Ast.Unop (unop, e) => evalUnaryOp (unop, e)
2939 :			| Ast.Binop (binop, e, e') => evalBinaryOp (binop, e, e')
2940 :			| Ast.QuestionColon (e0,e1,e2) =>
2941 :			(case evalAstExpr e0
2942 :			of SOME 0 => evalAstExpr e2
2943 :			| SOME _ => evalAstExpr e1
2944 :			| NONE => NONE)
2945 :			| Ast.Cast (ct,e) =>
2946 :			let val eTy = lookAid adorn
2947 :			in if compatible (ct, eTy) then ()
2948 :			else warn "evalExpr: cast not handled yet";
2949 :			evalAstExpr e
2950 :			end
2951 :			| Ast.EnumId (_, i) => SOME i
2952 :			| Ast.SizeOf ct => (encounteredSizeof := true;
2953 :			SOME(sizeof ct))
2954 :			| _ => NONE
2955 :
2956 :			and evalBinaryOp (binop, e, e') =
2957 :			let val opt = evalAstExpr e
2958 :			val opt' = evalAstExpr e'
2959 :			in
2960 :			if isSome opt andalso isSome opt' then
2961 :			let val i = valOf opt
2962 :			val i' = valOf opt'
2963 :			in case binop
2964 :			of Ast.Plus => SOME (i + i')
2965 :			| Ast.Minus => SOME (i - i')
2966 :			| Ast.Times => SOME (i * i')
2967 :			| Ast.Divide => SOME (LargeInt.quot (i,i'))
2968 :			| Ast.Mod => SOME (LargeInt.rem (i,i'))
2969 :			| Ast.Gt => SOME (if i > i' then 1 else 0)
2970 :			| Ast.Lt => SOME (if i < i' then 1 else 0)
2971 :			| Ast.Gte => SOME (if i >= i' then 1 else 0)
2972 :			| Ast.Lte => SOME (if i <= i' then 1 else 0)
2973 :			| Ast.Eq => SOME (if i = i' then 1 else 0)
2974 :			| Ast.Neq => SOME (if i <> i' then 1 else 0)
2975 :			| Ast.And => SOME (if i<>0 andalso i'<>0 then 1 else 0)
2976 :			| Ast.Or => SOME (if i<>0 orelse i'<>0 then 1 else 0)
2977 :			| Ast.BitOr =>
2978 :			SOME (W.toLargeInt (W.orb (W.fromLargeInt i, W.fromLargeInt i')))
2979 :			| Ast.BitXor =>
2980 :			SOME (W.toLargeInt (W.xorb (W.fromLargeInt i, W.fromLargeInt i')))
2981 :			| Ast.BitAnd =>
2982 :			SOME (W.toLargeInt (W.andb (W.fromLargeInt i, W.fromLargeInt i')))
2983 :			| Ast.Lshift =>
2984 :			SOME (W.toLargeInt (W.<< (W.fromLargeInt i, W.fromLargeInt i')))
2985 :			| Ast.Rshift =>
2986 :			SOME (W.toLargeInt (W.>> (W.fromLargeInt i, W.fromLargeInt i')))
2987 :			| _ => NONE
2988 :			end
2989 :			else
2990 :			NONE
2991 :			end
2992 :
2993 :			and evalUnaryOp (unop, e) =
2994 :			let
2995 :			val opt = evalAstExpr e
2996 :			in
2997 :			if isSome opt then
2998 :			let
2999 :			val i = valOf opt
3000 :			in case unop
3001 :			of Ast.Negate => SOME (~i)
3002 :			| Ast.Not => SOME (if i = 0 then 1 else 0)
3003 :			| Ast.Uplus => SOME i
3004 :			| Ast.BitNot => SOME (W.toLargeInt (W.notb (W.fromLargeInt i)))
3005 :			| _ => NONE
3006 :			end
3007 :			else NONE
3008 :			end
3009 :			in (evalAstExpr e', eTy, e', !encounteredSizeof)
3010 :			end
3011 :
3012 :			(* --------------------------------------------------------------------
3013 :			* makeAst' : ParseTree.external_decl list * Error.errorState -> Ast.ast
3014 :			*
3015 :			* Converts a parse tree into an ast, by recursively converting
3016 :			* each delcaration in the list.
3017 :			* -------------------------------------------------------------------- *)
3018 :
3019 :			(* initializing extension conversion functions *)
3020 :
3021 :			val _ =
3022 :			let val coreFuns = {stateFuns=stateFuns,
3023 :	dbm	639	mungeTyDecr=(fn (ty, decr) =>
3024 :			let val (ctype, name, _) =
3025 :			mungeTyDecr(ty,decr)
3026 :			in (ctype, name) end),
3027 :			(* since we added location in the output of mungeTyDecr and
3028 :			* we don't want to change the extension interface *)
3029 :	dbm	597	cnvType=cnvType,
3030 :			cnvExpression=cnvExpression,
3031 :			cnvStatement=cnvStatement,
3032 :			cnvExternalDecl=cnvExternalDecl,
3033 :			wrapEXPR=wrapEXPR,
3034 :			wrapSTMT=wrapSTMT,
3035 :			wrapDECL=wrapDECL}
3036 :			val {CNVExp, CNVStat, CNVBinop, CNVUnop, CNVExternalDecl,
3037 :			CNVSpecifier, CNVDeclarator, CNVDeclaration} = CnvExt.makeExtensionFuns coreFuns
3038 :			in
3039 :			refCNVExp := CNVExp;
3040 :			refCNVStat := CNVStat;
3041 :			refCNVBinop := CNVBinop;
3042 :			refCNVUnop := CNVUnop;
3043 :			refCNVExternalDecl := CNVExternalDecl;
3044 :			refCNVSpecifier := CNVSpecifier;
3045 :			refCNVDeclarator := CNVDeclarator;
3046 :			refCNVDeclaration := CNVDeclaration
3047 :			end
3048 :
3049 :			fun makeAst' extDecls =
3050 :			let val _ = if !multi_file_mode then print "Warning: multi_file_mode on\n"
3051 :			else ()
3052 :			val _ = Sizeof.reset()
3053 :			(* this is the top-level call for this structure;
3054 :			* must reset sizeof memo table *)
3055 :			val astExtDecls =
3056 :			let fun process x =
3057 :			let val astExtDecl = cnvExternalDecl x
3058 :			val newtids = resetTids ()
3059 :			in (List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=NONE, tid=x})))
3060 :			newtids)
3061 :			@ astExtDecl
3062 :			end
3063 :			in List.map process extDecls
3064 :			end
3065 :			val astExtDecls = List.concat astExtDecls
3066 :			val errorCount = Error.errorCount errorState
3067 :			val warningCount = Error.warningCount errorState
3068 :			in
3069 :			{ast=astExtDecls, tidtab=ttab, errorCount=errorCount, warningCount=warningCount,
3070 :			auxiliaryInfo = {aidtab=atab, implicits=implicits, env=getGlobalEnv()}}
3071 :			(* DBM: will we want to reuse errorState? *)
3072 :			end (* fun makeAst' *)
3073 :
3074 :			in
3075 :			makeAst'
3076 :			end (* fun makeAst *)
3077 :
3078 :			end (* local open Bindings *)
3079 :
3080 :			end (* structure BuildAst *)

---

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