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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 639 - (view) (download)
Original Path: sml/trunk/ckit/src/ast/build-ast.sml

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 :     val (initExprOpt, ty) =
903 :     case expr
904 :     of PT.EmptyExpr => (NONE, ty)
905 :     | _ =>
906 :     let
907 :     val e = cnvInitExpression expr
908 :     val _ = constCheckIE e
909 :     val (e',ty') = checkInitializer(ty, e, auto)
910 :     in
911 :     if equalType(ty', ty) then () (* nothing more to do *)
912 :     else (* fix up type of id *)
913 :     (case lookSym varSym of
914 :     SOME(B.ID x) =>
915 :     let val {name, uid, location, ctype, stClass, status, global, kind} = x
916 :     val id =
917 :     {name=name, uid=uid, location=location, ctype=ty',
918 :     stClass=stClass, status=status, global=global, kind=kind}
919 :     in
920 :     bindSym (varSym, ID id)
921 :     end
922 :     | _ => () (* can never arise: id must have ID binding *)
923 :     );
924 :     (SOME e', ty')
925 :     end
926 :    
927 :     (* Now do storage size check: can't do it earlier, because type might
928 :     be incomplete, and only completed by processing the initializer. *)
929 :    
930 :     val _ =
931 :     if storage_size_check then
932 :     if hasKnownStorageSize ty then ()
933 :     else (case sc
934 :     of Ast.EXTERN => ()
935 :     | _ =>
936 :     error
937 :     ("Storage size of `"
938 :     ^ Sym.name varSym
939 :     ^ "' is not known (e.g. incomplete type, void)"))
940 :     else ()
941 :    
942 :     in (id, initExprOpt)
943 :     end
944 :    
945 :    
946 :     (* processTypedef :
947 :     * Ast.ctype -> ParseTree.declarator -> ()
948 :     * (storage class simply meant to discriminate between top-level (STATIC) and
949 :     * local (AUTO))
950 :     *)
951 :     and processTypedef ty decr =
952 :     if !multi_file_mode then (* version of processTypede for multi_file_mode *)
953 :     let
954 : dbm 639 val (ty,nameOpt,loc) = mungeTyDecr (ty, decr)
955 : dbm 597 val name =
956 :     case nameOpt
957 :     of SOME name => name
958 :     | NONE =>
959 :     (error
960 :     "Missing declarator in typedef - filling with missing_typedef_name";
961 :     "missing_typedef_name")
962 :    
963 :     val sym = Sym.typedef name
964 :    
965 :     val tidOpt =
966 :     (case lookLocalScope sym
967 :     of SOME(TYPEDEF{ctype=ty, location=loc',...}) =>
968 :     (case ty
969 :     of Ast.TypeRef tid =>
970 :     if repeated_declarations_ok then SOME tid
971 :     else (error
972 :     ("Redeclaration of typedef `" ^
973 :     (Sym.name sym) ^
974 :     "'; previous declaration at " ^
975 :     SM.locToString loc');
976 :     NONE)
977 :     | _ => (error
978 :     ("Redeclaration of typedef `" ^
979 :     (Sym.name sym) ^
980 :     "'; previous declaration at " ^
981 :     SM.locToString loc');
982 :     NONE))
983 :     | SOME binding =>
984 :     (error
985 :     ("Redeclaration of `" ^
986 :     (Sym.name sym) ^
987 :     "' as a typedef; previous declaration at " ^
988 :     SM.locToString (getBindingLoc binding));
989 :     NONE)
990 :     | NONE => NONE) (* not bound locally *)
991 :    
992 :    
993 :     val tid =
994 :     case tidOpt
995 :     of SOME tid => tid
996 :     | NONE => Tid.new () (* create a new named type id *)
997 :    
998 :     val ty' = Ast.TypeRef tid
999 :     (* store actual typdef symbol mapped to named type id *)
1000 :     val _ = checkNonIdRebinding(sym, ty', "typedef ")
1001 :    
1002 : dbm 639 val binding = TYPEDEF{name = sym, uid = Pid.new(), location = loc,
1003 : dbm 597 ctype = ty'}
1004 :    
1005 :     (* store named type id mapped to typedef in named-type table *)
1006 :     in bindSym(sym, binding);
1007 :     bindTid (tid, {name=SOME name, ntype=SOME(B.Typedef (tid,ty)),
1008 :     global = topLevel(), location=getLoc()});
1009 :     tid
1010 :     end
1011 :     else (* standard version of processTypedef *)
1012 :     (* In time the two version should be combined. *)
1013 : dbm 639 let val (ty,nameOpt,loc) = mungeTyDecr (ty, decr)
1014 : dbm 597 val name =
1015 :     case nameOpt
1016 :     of SOME name => name
1017 :     | NONE =>
1018 :     (error
1019 :     "Missing declarator in typedef - filling with missing_typedef_name";
1020 :     "missing_typedef_name")
1021 :     val sym = Sym.typedef name
1022 :    
1023 :     (* create a new named type id *)
1024 :     val tid = Tid.new ()
1025 :     val ty' = Ast.TypeRef tid
1026 :    
1027 :     val _ = checkNonIdRebinding(sym, ty', "typedef ")
1028 :    
1029 : dbm 639 val binding = TYPEDEF{name = sym, uid = Pid.new(), location = loc,
1030 : dbm 597 ctype = ty'}
1031 :    
1032 :     (* store named type id mapped to typedef in named-type table *)
1033 :     in bindSym (sym, binding);
1034 :     bindTid (tid, {name=SOME name, ntype=SOME (B.Typedef (tid,ty)),
1035 :     global = topLevel(), location=getLoc()});
1036 :     tid
1037 :     end
1038 :    
1039 :    
1040 :     (* like processDeclarator, except it munges a Ast.ctype with
1041 :     * a PT.declarator *)
1042 : dbm 639 and mungeTyDecr (ty: Ast.ctype, decr : PT.declarator)
1043 :     : Ast.ctype * string option * SourceMap.location =
1044 : dbm 597 case decr
1045 : dbm 639 of PT.VarDecr str => (ty,SOME str,getLoc())
1046 : dbm 597 | PT.PointerDecr decr => mungeTyDecr (Ast.Pointer ty, decr)
1047 :     | PT.ArrayDecr (decr,PT.EmptyExpr) => mungeTyDecr(Ast.Array (NONE, ty), decr)
1048 :     | PT.ArrayDecr (decr,sz) =>
1049 :     let val (i, aexpr) = case evalExpr sz (* cannot be EmptyExpr *)
1050 :     of
1051 :     (SOME i, _, aexpr, _) => (if i=0 then warn "Array has zero size." else ();
1052 :     (i, aexpr))
1053 :     | (NONE, _, aexpr, _) => (error "Array must have constant size.";
1054 :     (0, aexpr))
1055 :     in
1056 :     mungeTyDecr(Ast.Array (SOME(i, aexpr), ty), decr)
1057 :     end
1058 :    
1059 :     | PT.FuncDecr (decr,lst) =>
1060 :     let fun folder (dt,decr) =
1061 :     let val ty = (dt2ct o #1) (processDeclarator (dt,decr))
1062 :     in cnvCtype (false, ty)
1063 :     end
1064 :     val argTys = List.map folder lst
1065 :     in mungeTyDecr(mkFunctionCt(ty, argTys), decr)
1066 :     end
1067 :     | PT.QualDecr (PT.CONST,decr) =>
1068 :     let val ty' = Ast.Qual (Ast.CONST,ty)
1069 :     (* dpo: is this check necessary?
1070 :     * Doesn't the 2nd call get the same info? *)
1071 :     val {redundantConst, ...} = checkQuals ty
1072 :     val {redundantConst=redundantConst', ...} = checkQuals ty'
1073 :     in if not redundantConst andalso redundantConst'
1074 :     then error "Duplicate `const'."
1075 :     else ();
1076 :     mungeTyDecr (ty', decr)
1077 :     end
1078 :     | PT.QualDecr (PT.VOLATILE,decr) =>
1079 :     let val ty' = Ast.Qual (Ast.VOLATILE,ty)
1080 :     val {redundantVolatile, ...} = checkQuals ty
1081 :     val {redundantVolatile=redundantVolatile', ...} = checkQuals ty'
1082 :     in if not(redundantVolatile) andalso redundantVolatile'
1083 :     then error "Duplicate `volatile'."
1084 :     else ();
1085 :     mungeTyDecr (ty', decr)
1086 :     end
1087 : dbm 639 | PT.EllipsesDecr => (Ast.Ellipses, SOME "**ellipses**", getLoc())
1088 :     | PT.EmptyDecr => (ty, NONE, getLoc())
1089 : dbm 597 | PT.MARKdeclarator(loc, decr) =>
1090 :     (pushLoc loc;
1091 :     mungeTyDecr(ty, decr)
1092 :     before popLoc ())
1093 : dbm 639 | PT.DecrExt ext =>
1094 :     let val (t,n) = CNVDeclarator (ty, ext) in (t,n,getLoc()) end
1095 : dbm 597
1096 :    
1097 :     (* --------------------------------------------------------------------
1098 :     * cnvExternalDecl : ParseTree.externalDecl -> Ast.externalDecl list
1099 :     *
1100 :     * Converts a parse-tree top-level declaration into an ast top-level
1101 :     * declaration by adding the necessary symbols and types to the
1102 :     * environment and recursively converting statements of function bodies.
1103 :     * -------------------------------------------------------------------- *)
1104 :    
1105 :     and cnvExternalDecl (PT.ExternalDecl(PT.DeclarationExt ext)) =
1106 :     let val declarations = CNVDeclaration ext
1107 :     in
1108 :     List.map (fn x => wrapDECL(Ast.ExternalDecl x)) declarations
1109 :     end
1110 :    
1111 :     | cnvExternalDecl (PT.ExternalDecl(PT.MARKdeclaration (loc,decl))) =
1112 :     (pushLoc loc;
1113 :     cnvExternalDecl(PT.ExternalDecl decl)
1114 :     before popLoc ())
1115 :    
1116 :     | cnvExternalDecl (PT.ExternalDecl(PT.Declaration(dt as {qualifiers, specifiers, storage},
1117 :     declExprs))) : Ast.externalDecl list =
1118 :     (* The following code is almost identical to corresponding case in processDecls ...
1119 :     Any changes made here should very likely be reflected in changes to the processDecls code. *)
1120 :     if isTYPEDEF dt then
1121 :     let val ct = {qualifiers=qualifiers, specifiers=specifiers}
1122 :     val decls = List.map (declExprToDecl "initializers in typedef") declExprs
1123 :     in (* global typedefs *)
1124 :     if List.null decls then (warn "empty typedef"; [])
1125 :     else
1126 :     let val ty = cnvCtype (false, ct)
1127 :     val tidl = List.map (processTypedef ty) decls
1128 :     in List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=NONE, tid=x}))) tidl
1129 :     end
1130 :     end
1131 :     else (* global variable and struct declarations *)
1132 :     let val isShadow = List.null declExprs andalso isTagTy dt
1133 :     (* isShadow does not necessarily mean "shadows a previous definition";
1134 :     rather, it refers to empty type declarations of the form
1135 :     struct t;
1136 :     enum e;
1137 :     Of course, the real use of these declarations is
1138 :     for defining mutually recursive structs/unions
1139 :     that reuse previously defined ids i.e. for shadowing....
1140 :     Note: if we had
1141 :     struct t x;
1142 :     then this would not be a shadow,
1143 :     hence the null declExprs test.
1144 :     *)
1145 :     val (ty,sc) = cnvType (isShadow, dt)
1146 :     in if isShadow
1147 :     then let fun getTid (Ast.StructRef tid) = SOME({strct=true}, tid)
1148 :     | getTid(Ast.UnionRef tid) = SOME({strct=false}, tid)
1149 :     | getTid(Ast.Qual(_, ct)) = getTid ct (* ignore qualifiers *)
1150 :     | getTid _ = NONE (* don't deref typerefs *)
1151 :     in
1152 :     case getTid ty of
1153 :     SOME(strct, tid) => [wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=SOME strct, tid=tid}))]
1154 :     | NONE => []
1155 :     end
1156 :     else
1157 :     let val idExprs = List.map (processDecr(ty,sc,true)) declExprs
1158 :     in List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.VarDecl x))) idExprs
1159 :     end
1160 :     end
1161 :    
1162 :     | cnvExternalDecl (PT.FunctionDef {retType as {qualifiers,specifiers,storage},
1163 :     funDecr, krParams: PT.declaration list, body}) =
1164 :     (* function definitions *)
1165 :     let
1166 : dbm 639 val (funTy, tagOpt, funLoc) = processDeclarator (retType, funDecr)
1167 : dbm 597 val funName = case tagOpt
1168 :     of SOME tag => tag
1169 :     | NONE =>
1170 :     (bug
1171 :     "Missing function name - \
1172 :     \filling with missing_function_name";
1173 :     "missing_function_name")
1174 :     val (retType, args) =
1175 :     case funTy
1176 :     of {specifiers=[PT.Function {retType,params}],...} => (retType, params)
1177 :     | _ =>(error "ill-formed function declaration";
1178 :     ({qualifiers=[],specifiers=[]}, nil))
1179 :    
1180 :     val retType' = cnvCtype (false,retType)
1181 :    
1182 :     val sc = cnvStorage storage
1183 :    
1184 :     (* check validity of storage class *)
1185 :     val _ = case sc
1186 :     of Ast.DEFAULT => ()
1187 :     | Ast.EXTERN => ()
1188 :     | Ast.STATIC => ()
1189 :     | _ => (error "`auto' and `register' are not allowed \
1190 :     \in function declarations")
1191 :    
1192 :     val argTyIdOpts = List.map processDeclarator args
1193 :     fun unzip3((x, y, z) :: l) =
1194 :     let val (xl, yl, zl) = unzip3 l
1195 :     in
1196 :     (x :: xl, y :: yl, z :: zl)
1197 :     end
1198 :     | unzip3 nil = (nil,nil, nil)
1199 :    
1200 :     fun zip3(x :: xl, y :: yl, z :: zl) = (x, y, z) :: (zip3(xl, yl, zl))
1201 :     | zip3 _ = nil
1202 :    
1203 :     val (argTys, argIdOpts, locs) = unzip3 argTyIdOpts
1204 :    
1205 :     fun noDeclType{specifiers=nil,qualifiers=nil,storage=nil} = true
1206 :     | noDeclType _ = false
1207 :    
1208 :     val krParamsAdmitted = List.all noDeclType argTys (* if true, K&R params are admitted *)
1209 :    
1210 :     (* enter a local scope - push a new symbol table *)
1211 :     val _ = pushLocalEnv ()
1212 :    
1213 :     (* insert (and convert) argument types in this symbol table *)
1214 :     (* this needs to be done left to right because the first
1215 :     * argument could define a type used in later args *)
1216 :     val argTyScList = List.map (fn ty => cnvType(false,ty)) argTys
1217 :    
1218 :     (* create a (ctype * storageClass) IdMap.map *)
1219 :     val argIds' =
1220 :     let
1221 :     fun iter ((SOME s) :: l) = (s :: (iter l))
1222 :     | iter (NONE :: l) = (warn "unnamed function argument";
1223 :     nil)
1224 :     | iter nil = nil
1225 :     in
1226 :     case argTyIdOpts of
1227 :     [({specifiers=[PT.Void], qualifiers=nil, storage=nil}, NONE, _)] => nil
1228 :     (* special case of function definition f(void) {...} *)
1229 :     | _ => iter argIdOpts
1230 :     end
1231 :    
1232 :     (* zipped list will be size of shorter list - if one is shorter *)
1233 :     val argTyScIdLocList = zip3 (argTyScList, argIds', locs)
1234 :     fun folder ((tySc,id,loc),mp) = IdMap.insert (mp, id, (tySc,false,loc))
1235 :     (* false component means hasn't been matched with K&R parameters spec *)
1236 :     val argMap = List.foldl folder IdMap.empty argTyScIdLocList
1237 :    
1238 :     (* check if krParams are ok *)
1239 :     val _ = if null krParams orelse krParamsAdmitted then ()
1240 :     else error "mixing of K&R params and prototype style params not allowed"
1241 :    
1242 :     (* rectify additional types from K&R style parameters *)
1243 :     val argMap =
1244 :     let
1245 :     fun folder (decl,argMap) =
1246 :     (case decl
1247 :     of PT.MARKdeclaration(loc,decl') =>
1248 :     (pushLoc loc;
1249 :     folder(decl',argMap) before
1250 :     popLoc())
1251 :     | PT.DeclarationExt _ =>
1252 :     (error "Declaration extensions not permitted in K&R parameter declarations";
1253 :     argMap)
1254 :     | PT.Declaration(decltype as {storage,...}, decrExprs) =>
1255 :     if isTYPEDEF decltype then (error "typedef in function parameter declaration";
1256 :     argMap)
1257 :     else let val decrs = List.map (declExprToDecl "initializer in function declaration") decrExprs
1258 :     val (ty,sc) = cnvType (false, decltype)
1259 :     fun folder' (decr, argMap) =
1260 : dbm 639 let val (ty, sOpt, loc) = mungeTyDecr (ty, decr)
1261 : dbm 597 val s =
1262 :     case sOpt
1263 :     of SOME s =>
1264 :     (case IdMap.find (argMap,s)
1265 :     of NONE =>
1266 :     (error "K&R parameter not in function's identifier list";
1267 :     s)
1268 :     | SOME (_,matched,_) =>
1269 :     if matched then
1270 :     (error ("repeated K&R declaration for parameter "^ s);
1271 :     s)
1272 :     else s)
1273 :     | NONE =>
1274 :     (error "Unnamed K&R style parameter - \
1275 :     \filling with unnamed_KR_parameter";
1276 :     "<unnamed_KR_parameter>")
1277 : dbm 639 val argMap = IdMap.insert
1278 :     (argMap, s, ((ty,sc),true,loc))
1279 : dbm 597 in argMap
1280 :     end
1281 :     in List.foldl folder' argMap decrs
1282 :     end)
1283 :     in
1284 :     List.foldl folder argMap krParams
1285 :     end
1286 :    
1287 :     fun mapper id =
1288 :     let val (p, loc) =
1289 :     case IdMap.find (argMap, id)
1290 :     of SOME (p,_,loc) => (p, loc)
1291 :     | NONE => (bug "mapper: inconsistent arg map";
1292 :     ((Ast.Error, Ast.DEFAULT), SM.UNKNOWN))
1293 :     in (p, id, loc)
1294 :     end
1295 :    
1296 :     val argTyScIdLocList' = List.map mapper argIds'
1297 :    
1298 :     fun checkStorageClass ((_,Ast.REGISTER),_, _) = ()
1299 :     | checkStorageClass ((_,Ast.DEFAULT),_, _) = () (* DBM: ??? *)
1300 :     | checkStorageClass _ =
1301 :     error "Only valid storage class for function parameters is `register'."
1302 :    
1303 :     val _ = List.map checkStorageClass argTyScIdLocList'
1304 :    
1305 :     (* insert function name in global scope *)
1306 :     val argTys' = #1 (ListPair.unzip (#1 (unzip3 argTyScIdLocList')))
1307 :     (* ASSERT: argument type list is null iff not a prototype style defn *)
1308 :     val funTy' = mkFunctionCt (retType', if null krParams then argTys' else nil)
1309 :     val funSym = Sym.func funName
1310 :     val (status, newTy, uidOpt) =
1311 :     checkIdRebinding(funSym, funTy', Ast.DEFINED, {globalBinding=true})
1312 :     val uid = case uidOpt of
1313 :     SOME uid => uid
1314 :     | NONE => Pid.new()
1315 : dbm 639 val funId = {name = funSym, uid = uid, location = funLoc,
1316 : dbm 597 ctype = funTy', stClass = sc, status = status,
1317 :     kind = Ast.FUNCTION{hasFunctionDef = true}, global = true}
1318 :     val binding = ID funId
1319 :    
1320 :     val _ = bindSymGlobal(funSym, binding)
1321 :     (* note: we've already pushed a local env for the function args, so
1322 :     we are no longer at top level -- we must use bindSymGlobal here! *)
1323 :    
1324 :     (* insert the arguments in the local symbol table *)
1325 :     val argPids =
1326 :     let fun bindArg ((ty,sc),name,loc) =
1327 :     let
1328 :     val ty = preArgConv ty (* array and function replaced by pointers *)
1329 :     val sym = Sym.object name
1330 :     val kind = Ast.NONFUN
1331 :     (* argument types cannot have function type:
1332 :     even if declared as function types,
1333 :     they are treated as function pointers. *)
1334 :     val id = {name = sym, uid = Pid.new(), location = loc,
1335 :     ctype = ty, stClass = sc, status=Ast.DECLARED,
1336 :     kind = kind, global = false}
1337 :     val _ = case lookLocalScope sym of
1338 :     NONE => ()
1339 :     | SOME _ => error ("Repeated function parameter " ^ (Sym.name sym))
1340 :     in bindSym(sym, ID id);
1341 :     id
1342 :     end
1343 :     in List.map bindArg argTyScIdLocList'
1344 :     end
1345 :    
1346 :     (* set new function context (labels and returns) *)
1347 :     val _ = newFunction retType'
1348 :     (* get new type declarations (tids) from retType and argTys *)
1349 :     val newtids = resetTids ()
1350 :    
1351 :     val bodyStmt = cnvStatement body
1352 :     (* note: what one might think of as an empty function body would
1353 :     * actually be a compound statement consisting of an empty list
1354 :     * of statements - thus all functions consist of one statement. *)
1355 :    
1356 :     in popLocalEnv ();
1357 :     case checkLabels ()
1358 :     of NONE => ()
1359 :     | SOME (lab,loc) =>
1360 :     Error.error(errorState, loc,
1361 :     "Label " ^ ((Sym.name lab))
1362 :     ^ "used but not defined.");
1363 :     (List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl({shadow=NONE, tid=x})))) newtids) @
1364 :     [wrapDECL(Ast.FunctionDef (funId, argPids, bodyStmt))]
1365 :     end
1366 :    
1367 :     | cnvExternalDecl (PT.MARKexternalDecl (loc,extDecl)) =
1368 :     (pushLoc loc;
1369 :     cnvExternalDecl extDecl
1370 :     before popLoc ())
1371 :     | cnvExternalDecl (PT.ExternalDeclExt extDecl) =
1372 :     CNVExternalDecl extDecl
1373 :    
1374 :     (* --------------------------------------------------------------------
1375 :     * cnvStatement : ParseTree.statement -> Ast.statement ternary_option
1376 :     *
1377 :     * Converts a parse-tree statement into an ast statement by adding the
1378 :     * necessary symbols and types to the environment and recursively converting
1379 :     * statements and expressions.
1380 :     *
1381 :     * A statement could be a type (or struct/union/enum) declaration which
1382 :     * only effects the environment, so return type is Ast.statement list
1383 :     * where the empty list is returned for such declarations.
1384 :     * A parse-tree statement can also be a variable declaration which
1385 :     * declares multiple variables in which case the result will be multiple
1386 :     * Ast statements. All other cases will result in one Ast.statement
1387 :     * being returned.
1388 :     *
1389 :     * In the parse tree, most (in principle all) statements have their
1390 :     * locations marked by being wrapped in a MARKstatement constructor.
1391 :     * In the ast, each core statement is wrapped by a STMT constructor
1392 :     * which also contains the location in the source file from where
1393 :     * the statement came. This is reflected in the structure of the
1394 :     * function: each MARKstatement causes the marked location to pushed
1395 :     * onto the stack in the environment, the wrapped statement is
1396 :     * recursively converted, then wrapped in a STMT constructor with the
1397 :     * location; finally the location is popped off the location stack in
1398 :     * the environment.
1399 :     * -------------------------------------------------------------------- *)
1400 :    
1401 :     and processDecls ((PT.Decl decl) :: rest, astdecls: Ast.declaration list list)
1402 :     : Ast.declaration list * PT.statement list =
1403 :     let fun processDeclaration (PT.Declaration(dt as {qualifiers, specifiers, ...}, declExprs)) =
1404 :     (* The following code is almost identical to corresponding case in cnvExternalDecl *)
1405 :     (* but we have deal with struct definitions -- cnvExternalDecl doesn't *)
1406 :     (* have to deal with them because makeAst' catches these at top level *)
1407 :     (* Any changes made here should very likely be reflected in changes to the cnvExternalDecl code. *)
1408 :     if isTYPEDEF dt then
1409 :     let val ct = {qualifiers=qualifiers, specifiers=specifiers}
1410 :     val decrs = List.map (declExprToDecl "initializer in typedef") declExprs
1411 :     in
1412 :     if List.null decrs
1413 :     then (warn "empty typedef";
1414 :     astdecls)
1415 :     else
1416 :     let val ty = cnvCtype (false, ct)
1417 :     val tidl = List.map (processTypedef ty) decrs
1418 :     val newtids = resetTids ()
1419 :     in (List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) tidl) ::
1420 :     (List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids) :: astdecls
1421 :     (* note: must process declarations left to right since we
1422 :     * could have e.g. int i=45, j = i; *)
1423 :     end
1424 :     end
1425 :     else
1426 :     let val isShadow = List.null declExprs andalso isTagTy dt
1427 :     val (ty,sc) = cnvType (isShadow, dt)
1428 :     (* ASSERT: null(tidsContext) *)
1429 :     (* ASSERT: not at top level (i.e. topLevel() => false) *)
1430 :     in if isShadow
1431 :     then let fun getTid (Ast.StructRef tid) = SOME({strct=true}, tid)
1432 :     | getTid(Ast.UnionRef tid) = SOME({strct=false}, tid)
1433 :     | getTid(Ast.Qual(_, ct)) = getTid ct (* ignore qualifiers *)
1434 :     | getTid _ = NONE (* don't deref typerefs *)
1435 :     in
1436 :     (case getTid ty of
1437 :     SOME(strct, tid) => [Ast.TypeDecl{shadow=SOME strct, tid=tid}]
1438 :     | NONE => []) ::
1439 :     (List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) (resetTids ()))(*should always be null*)
1440 :     :: astdecls
1441 :     end
1442 :     else let
1443 :     val idExprs =
1444 :     List.map (processDecr (ty,sc,false)) declExprs
1445 :     (* note: must process declarations left to right since we
1446 :     * could have e.g. int i=45, j = i; *)
1447 :     val newtids = resetTids ()
1448 :     in (List.map Ast.VarDecl idExprs) ::
1449 :     (List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids) :: astdecls
1450 :     (* DBM: push decl lists onto astdecls in reverse order since
1451 :     * astdecls will be reversed before flattening *)
1452 :     end
1453 :     end
1454 :     | processDeclaration(PT.DeclarationExt ext) =
1455 :     let val declarations = CNVDeclaration ext
1456 :     in declarations :: astdecls
1457 :     end
1458 :     | processDeclaration(PT.MARKdeclaration(newloc, decl)) =
1459 :     (pushLoc newloc;
1460 :     processDeclaration decl
1461 :     before popLoc ())
1462 :     in
1463 :     processDecls(rest, processDeclaration decl)
1464 :     end
1465 :    
1466 : dbm 639 | processDecls((PT.MARKstatement (newloc,stmt as PT.Decl _)) :: rest,
1467 :     astdecls) =
1468 : dbm 597 (pushLoc newloc;
1469 :     processDecls(stmt :: rest, astdecls)
1470 :     before popLoc ())
1471 :    
1472 : dbm 639 | processDecls((PT.MARKstatement (newloc,stmt as PT.MARKstatement _)) :: rest,
1473 :     astdecls ) =
1474 :     processDecls(stmt :: rest, astdecls)
1475 :    
1476 : dbm 597 | processDecls (rest, astdecls) = (List.concat(rev astdecls), rest)
1477 :    
1478 :     (* cnvStatement : PT.statement -> Ast.statement *)
1479 :     and cnvStatement (stmt: PT.statement): Ast.statement =
1480 :     (case stmt
1481 :     of PT.Expr PT.EmptyExpr => wrapSTMT(Ast.Expr NONE)
1482 :     | PT.Expr e =>
1483 :     let val (_, e') = cnvExpression e
1484 :     in wrapSTMT(Ast.Expr(SOME e'))
1485 :     end
1486 :     | PT.Compound stmts =>
1487 :     (pushLocalEnv ();
1488 :     let val (decls,rest) = processDecls(stmts,[])
1489 :     val stmts = List.map cnvStatement rest
1490 :     val newtids = resetTids ()
1491 :     val newTmps = resetTmpVars()
1492 :     val tmpdecls = List.map (fn pid => Ast.VarDecl(pid, NONE)) newTmps
1493 :     val typedecls = List.map (fn tid => Ast.TypeDecl{shadow=NONE, tid=tid}) newtids
1494 :     in wrapSTMT(Ast.Compound(decls@tmpdecls@typedecls,stmts))
1495 :     end
1496 :     before popLocalEnv ())
1497 :     | PT.Decl _ =>
1498 :     (* shouldn't occur; process decls anyway, but discard them *)
1499 :     (error "unexpected declaration";
1500 :     processDecls([stmt],[]);
1501 :     (* may violate assertion topLevel() = false for processDecls *)
1502 :     wrapSTMT(Ast.ErrorStmt))
1503 :     | PT.While (expr, stmt) =>
1504 :     let val (exprTy, expr') = cnvExpression expr
1505 :     val stmt = cnvStatement stmt
1506 :     in if perform_type_checking andalso not(isScalar exprTy)
1507 :     then error
1508 :     "Type Error: condition of while statement is not scalar."
1509 :     else ();
1510 :     wrapSTMT(Ast.While (expr',stmt))
1511 :     end
1512 :     | PT.Do (expr, stmt) =>
1513 :     let val (exprTy, expr') = cnvExpression expr
1514 :     val stmt = cnvStatement stmt
1515 :     in if perform_type_checking andalso not(isScalar exprTy)
1516 :     then error
1517 :     "Type Error: condition of do statement is not scalar."
1518 :     else ();
1519 :     wrapSTMT(Ast.Do (expr',stmt))
1520 :     end
1521 :     | PT.For (expr1,expr2,expr3,stmt) =>
1522 :     let val expr1' =
1523 :     (case expr1
1524 :     of PT.EmptyExpr => NONE
1525 :     | _ => SOME(#2 (cnvExpression expr1)))
1526 :     val expr2' =
1527 :     (case expr2
1528 :     of PT.EmptyExpr => NONE
1529 :     | _ =>
1530 :     let val (exprTy,expr2') = cnvExpression expr2
1531 :     in if perform_type_checking andalso not(isScalar exprTy)
1532 :     then error
1533 :     "Type Error: condition of for statement is not scalar."
1534 :     else ();
1535 :     SOME expr2'
1536 :     end)
1537 :     val expr3' =
1538 :     (case expr3
1539 :     of PT.EmptyExpr => NONE
1540 :     | _ => SOME(#2 (cnvExpression expr3)))
1541 :     val stmt = cnvStatement stmt
1542 :     in wrapSTMT(Ast.For (expr1',expr2',expr3',stmt))
1543 :     end
1544 :     | PT.Labeled (s,stmt) =>
1545 :     let val stmt = cnvStatement stmt
1546 :     val labelSym = Sym.label s
1547 :     val label = addLabel(labelSym, getLoc())
1548 :     in wrapSTMT(Ast.Labeled (label, stmt))
1549 :     end
1550 :     | PT.CaseLabel (expr, stmt) =>
1551 :     let val n = case expr of
1552 :     PT.EmptyExpr => (error "Non-constant case label."; 0)
1553 :     | _ => (case evalExpr expr of (* cannot be EmptyExpr *)
1554 :     (SOME i, _, _, sizeofFl) =>
1555 :     (if sizeofFl andalso not(!reduce_sizeof)
1556 :     then warn("sizeof in case label not preserved in source-to-source mode.")
1557 :     else ();
1558 :     i)
1559 :     | (NONE, _, _, _) => (error "Non-constant case label."; 0))
1560 :     in case addSwitchLabel n
1561 :     of NONE => ()
1562 :     | SOME msg => error msg;
1563 :     wrapSTMT(Ast.CaseLabel (n, (cnvStatement stmt)))
1564 :     end
1565 :     | PT.DefaultLabel stmt =>
1566 :     let val stmt = cnvStatement stmt
1567 :     in case addDefaultLabel ()
1568 :     of NONE => ()
1569 :     | SOME msg => error msg;
1570 :     wrapSTMT(Ast.DefaultLabel (stmt))
1571 :     end
1572 :     | PT.Goto s =>
1573 :     let val labSym = Sym.label s
1574 :     val label = addGoto(labSym, getLoc())
1575 :     in wrapSTMT(Ast.Goto label)
1576 :     end
1577 :     | PT.Break => wrapSTMT(Ast.Break)
1578 :     | PT.Continue => wrapSTMT(Ast.Continue)
1579 :     | PT.Return expr =>
1580 :     let val (exprTy, expr') =
1581 :     case expr
1582 :     of PT.EmptyExpr => (Ast.Void, NONE)
1583 :     | _ =>
1584 :     let val (ty,expr) = cnvExpression expr
1585 :     in (ty, SOME expr)
1586 :     end
1587 :     val returnTy = getReturnTy ()
1588 :     val _ =
1589 :     if perform_type_checking then
1590 :     (case returnTy
1591 :     of SOME returnTy =>
1592 :     if isAssignableTys{lhsTy=returnTy,
1593 :     rhsTy=exprTy,
1594 :     rhsExprOpt=case expr'
1595 :     of SOME expr'' =>
1596 :     SOME(getCoreExpr expr'')
1597 :     | NONE => NONE}
1598 :     then ()
1599 :     else
1600 :     let val lhs = ctToString returnTy
1601 :     val rhs = ctToString exprTy
1602 :     in case expr of
1603 :     PT.EmptyExpr => warn "missing return value."
1604 :     (* lcc gives this a warning: check ISO standard... *)
1605 :     | _ => error
1606 :     ( "Type Error: returning expression has illegal type " ^ rhs
1607 :     ^ ".\n Function has return type " ^ lhs ^ "."
1608 :     )
1609 :     end
1610 :     | NONE => ())
1611 :     else ()
1612 :     in wrapSTMT((Ast.Return expr'))
1613 :     end
1614 :     | PT.IfThen (expr,stmt) =>
1615 :     let val (exprTy, expr') = cnvExpression expr
1616 :     val stmt = cnvStatement stmt
1617 :     in if perform_type_checking andalso not(isScalar exprTy)
1618 :     then error
1619 :     "Type Error: condition of if statement is not scalar."
1620 :     else ();
1621 :     wrapSTMT(Ast.IfThen (expr',stmt))
1622 :     end
1623 :     | PT.IfThenElse (expr, stmt1, stmt2) =>
1624 :     let val (exprTy, expr') = cnvExpression expr
1625 :     val stmt1 = cnvStatement stmt1
1626 :     val stmt2 = cnvStatement stmt2
1627 :     in if perform_type_checking andalso not(isScalar exprTy)
1628 :     then error
1629 :     "Type Error: condition of if statement is not scalar."
1630 :     else ();
1631 :     wrapSTMT(Ast.IfThenElse (expr', stmt1, stmt2))
1632 :     end
1633 :     | PT.Switch (expr, stmt) =>
1634 :     let val (exprTy, expr') = cnvExpression expr
1635 :     val _ =
1636 :     if perform_type_checking andalso not(isIntegral exprTy)
1637 :     then error
1638 :     "The controlling expression of switch statement \
1639 :     \is not of integral type."
1640 :     else ()
1641 :     val _ = pushSwitchLabels ()
1642 :     val stmt = cnvStatement stmt
1643 :     in popSwitchLabels ();
1644 :     wrapSTMT(Ast.Switch(expr',stmt))
1645 :     end
1646 :     | PT.StatExt stmt =>
1647 :     CNVStat stmt
1648 :     | PT.MARKstatement (newloc,stmt) =>
1649 :     (pushLoc newloc;
1650 :     cnvStatement stmt
1651 :     before popLoc ()))
1652 :    
1653 :    
1654 :     (* --------------------------------------------------------------------
1655 :     * cnvExpression : ParseTree.expression -> Ast.ctype * Ast.expression
1656 :     *
1657 :     * Converts a parse-tree expression into an ast expression by
1658 :     * recursively converting subexpressions.
1659 :     *
1660 :     * In the ast, each core statement is wrapped by an EXPR constructor
1661 :     * which also contains the nearest marked location in the source file
1662 :     * from which the expression came. This is reflected in the structure
1663 :     * of the function: each parse-tree expression is converted into an ast
1664 :     * core expression and then wrapped in EXPR along with the current
1665 :     * location indicated by the environment and a unique
1666 :     * adornment. Subsequently each ast expression can be referred to by
1667 :     * its adornment. Along the way, the type of each expression is
1668 :     * calculated and stored in the environment in a map from expression
1669 :     * adornments to types.
1670 :     *
1671 :     * The fact that types are computed for each expression does _not_ mean
1672 :     * that this is a type checker. The bare minimum type checking is done
1673 :     * to allow for the expression-adornment-type map to be built. (* DBM ??? *)
1674 :     * -------------------------------------------------------------------- *)
1675 :    
1676 :     and cnvExpression expr =
1677 :     let
1678 :     fun numberOrPointer (ty, s) =
1679 :     if isNumberOrPointer ty then ()
1680 :     else error ("Type Error: operand of " ^ s ^
1681 :     " must be a number or a pointer.")
1682 :    
1683 :     fun number (ty, s) =
1684 :     if isNumber ty then ()
1685 :     else error("Type Error: operand of " ^ s ^ " must be a number.")
1686 :    
1687 :     fun mkBinopExp((ty1, ty2, resTy), expr1, expr2, binop) =
1688 :     let val resTy = getCoreType resTy
1689 :     in
1690 :     wrapEXPR(resTy, Ast.Binop (binop, wrapCast(ty1, expr1), wrapCast(ty2, expr2)))
1691 :     end
1692 :    
1693 :     fun mkUnopExp((ty, resTy), expr, unop) =
1694 :     let val resTy = getCoreType resTy
1695 :     in
1696 :     wrapEXPR(resTy, Ast.Unop (unop, wrapCast(ty, expr)))
1697 :     end
1698 :    
1699 :     fun mkBinaryAssignOpExp((newTy1, newTy2, resTy), ty1, expr1, ty2, expr2, assignOp, simpleOp) =
1700 :     let val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1, rhsTy=resTy, rhsExprOpt=NONE}
1701 :     fun getTy(Ast.EXPR(_, adorn, _)) = getCoreType(lookAid adorn)
1702 :     in
1703 :     if !reduce_assign_ops then
1704 :     simplifyAssignOps(processBinop, simpleOp, {preOp=true}, expr1, expr2)
1705 :     else
1706 :     (if CTypeEq.eqCType(getTy expr1, getCoreType newTy1) then ()
1707 :     else noteImplicitConversion(expr1, newTy1);
1708 :     if CTypeEq.eqCType(getTy expr2, getCoreType newTy2) then ()
1709 :     else noteImplicitConversion(expr2, newTy2);
1710 :     mkBinopExp((ty1, ty2, ty1), expr1, expr2, assignOp)) (* result type is (getCoreType ty1) *)
1711 :     end
1712 :    
1713 :     and mkUnaryAssignOpExp((newTy1, newTy2, resTy), ty1, expr1, preOp, assignOp, simpleOp) =
1714 :     let
1715 :     val (oneTy, one) = wrapEXPR(stdInt, Ast.IntConst 1) (* implicit one constant
1716 :     -- all unaryassignops use one *)
1717 :     val expr2 = one
1718 :     val ty2 = oneTy
1719 :     val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1, rhsTy=resTy, rhsExprOpt=NONE}
1720 :     in
1721 :     if !reduce_assign_ops then
1722 :     simplifyAssignOps(processBinop, simpleOp, preOp, expr1, expr2)
1723 :     else
1724 :     mkUnopExp((ty1, ty1), expr1, assignOp) (* result type is (getCoreType ty1) *)
1725 :     end
1726 :    
1727 :     and scaleExpr (size: LargeInt.int, expr as Ast.EXPR(_, adorn, _)) =
1728 :     let
1729 :     val ty1 = lookAid adorn
1730 :     val expr1 = expr
1731 :     val ty2 = stdInt
1732 :     val (_, expr2) = wrapEXPR(ty2, Ast.IntConst size)
1733 :     in
1734 :     processBinop(ty1, expr1, ty2, expr2, PT.Times)
1735 :     end
1736 :    
1737 :     and scalePlus(ty1, expr1, ty2, expr2) = (* scale integer added to pointer *)
1738 :     case (!insert_scaling, isPointer ty1, isPointer ty2) of
1739 :     (true, true, false) => let val (ty2, expr2) = scaleExpr(sizeof(deref ty1), expr2)
1740 :     in
1741 :     (ty1, expr1, ty2, expr2)
1742 :     end
1743 :     | (true, false, true) => let val (ty1, expr1) = scaleExpr(sizeof(deref ty2), expr1)
1744 :     in
1745 :     (ty1, expr1, ty2, expr2)
1746 :     end
1747 :     | _ => (ty1, expr1, ty2, expr2) (* no change *)
1748 :    
1749 :     and scaleMinus(ty1, ty2, expr2) = (* scale integer subtracted from pointer *)
1750 :     case (!insert_scaling, isPointer ty1, isPointer ty2) of
1751 :     (true, true, false) => let val (ty2, expr2) = scaleExpr(sizeof(deref ty1), expr2)
1752 :     in
1753 :     (ty2, expr2)
1754 :     end
1755 :     | _ => (ty2, expr2) (* no change *)
1756 :    
1757 :     and plusOp (ty1, ty2) = (* type check plus *)
1758 :     if perform_type_checking then
1759 :     (case isAddable {ty1=ty1, ty2=ty2}
1760 :     of SOME{ty1, ty2, resTy} => (ty1, ty2, resTy)
1761 :     | NONE => (error
1762 :     "Type Error: Unacceptable operands of \"+\" or \"++\".";
1763 :     (ty1, ty2, ty1)))
1764 :     else
1765 :     (ty1, ty2, ty1)
1766 :    
1767 :     and minusOp (ty1, ty2) =
1768 :     if perform_type_checking then
1769 :     (case isSubtractable {ty1=ty1, ty2=ty2} of
1770 :     SOME{ty1, ty2, resTy} => (ty1, ty2, resTy)
1771 :     | NONE => (error
1772 :     "Type Error: Unacceptable operands of \"-\" or \"--\".";
1773 :     (ty1, ty2, ty1)))
1774 :     else
1775 :     (ty1, ty2, ty1)
1776 :    
1777 :     and processBinop(ty1, expr1, ty2, expr2, expop) =
1778 :     let
1779 :     fun eqOp(ty1, exp1, ty2, exp2) = (* see H&S p208 *)
1780 :     if perform_type_checking then
1781 :     (case isEquable {ty1=ty1, exp1Zero=isZeroExp exp1,
1782 :     ty2=ty2, exp2Zero=isZeroExp exp2}
1783 :     of SOME ty => (ty, ty, signedNum Ast.INT)
1784 :     | NONE =>
1785 :     (error
1786 :     "Type Error: bad types for arguments of eq/neq operator.";
1787 :     (ty1, ty2, signedNum Ast.INT)))
1788 :     else (ty1, ty2, signedNum Ast.INT)
1789 :    
1790 :     fun comparisonOp(ty1, ty2) = (* see H&S p208 *)
1791 :     if perform_type_checking then
1792 :     (case isComparable {ty1=ty1, ty2=ty2} of
1793 :     SOME ty => (ty, ty, signedNum Ast.INT)
1794 :     | NONE => (error
1795 :     "Type Error: bad types for arguments of \
1796 :     \comparison operator.";
1797 :     (ty1, ty2, signedNum Ast.INT)))
1798 :     else (ty1, ty2, signedNum Ast.INT)
1799 :    
1800 :     fun logicalOp2(ty1, ty2) = (* And and Or *)
1801 :     let val stdInt = signedNum Ast.INT
1802 :     in if perform_type_checking then
1803 :     if isNumberOrPointer ty1
1804 :     andalso isNumberOrPointer ty2
1805 :     then (stdInt, stdInt, stdInt)
1806 :     else
1807 :     (error
1808 :     "Type Error: Unacceptable argument of logical operator.";
1809 :     (ty1, ty2, signedNum Ast.INT))
1810 :     else (ty1, ty2, signedNum Ast.INT)
1811 :     end
1812 :    
1813 :     fun integralOp(ty1, ty2) =
1814 :     if perform_type_checking then
1815 :     if isIntegral ty1 andalso isIntegral ty2
1816 :     then (case usualBinaryCnv (ty1, ty2) of
1817 :     SOME ty => (ty, ty, ty)
1818 :     | NONE =>
1819 :     (bug "cnvExpression: integralOp.";
1820 :     (ty1, ty2, signedNum Ast.INT)))
1821 :     else
1822 :     (error
1823 :     "Type Error: arguments of mod, shift and \
1824 :     \bitwise operators must be integral numbers.";
1825 :     (ty1, ty2, signedNum Ast.INT))
1826 :     else (ty1, ty2, signedNum Ast.INT)
1827 :    
1828 :     fun mulDivOp(ty1, ty2) =
1829 :     if perform_type_checking then
1830 :     if isNumber ty1
1831 :     andalso isNumber ty2
1832 :     then (case usualBinaryCnv (ty1, ty2) of
1833 :     SOME ty => (ty, ty, ty)
1834 :     | NONE =>
1835 :     (bug
1836 :     "usualBinaryCnv should \
1837 :     \succeed for numeric types.";
1838 :     (ty1, ty2, signedNum Ast.INT)))
1839 :     else
1840 :     (error
1841 :     "Type Error: arguments of mul and div must be numbers.";
1842 :     (ty1, ty2, signedNum Ast.INT))
1843 :     else
1844 :     (ty1, ty2, ty1)
1845 :    
1846 :     in case expop
1847 :     of PT.Plus =>
1848 :     let val (ty1, expr1, ty2, expr2) = scalePlus(ty1, expr1, ty2, expr2)
1849 :     val resTy = plusOp(ty1, ty2)
1850 :     in
1851 :     mkBinopExp(resTy, expr1, expr2, Ast.Plus)
1852 :     end
1853 :     | PT.Minus =>
1854 :     let val (ty2, expr2) = scaleMinus(ty1, ty2, expr2)
1855 :     val resTy = minusOp(ty1, ty2)
1856 :     in
1857 :     mkBinopExp(resTy, expr1, expr2, Ast.Minus)
1858 :     end
1859 :     | PT.Times => mkBinopExp(mulDivOp(ty1, ty2), expr1, expr2, Ast.Times)
1860 :     | PT.Divide => mkBinopExp(mulDivOp(ty1, ty2), expr1, expr2, Ast.Divide)
1861 :     | PT.Mod => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Mod)
1862 :     | PT.Eq => mkBinopExp(eqOp(ty1, expr1, ty2, expr2), expr1, expr2, Ast.Eq)
1863 :     | PT.Neq => mkBinopExp(eqOp(ty1, expr1, ty2, expr2), expr1, expr2, Ast.Neq)
1864 :     | PT.Gt => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Gt)
1865 :     | PT.Lt => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Lt)
1866 :     | PT.Gte => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Gte)
1867 :     | PT.Lte => mkBinopExp(comparisonOp(ty1, ty2), expr1, expr2, Ast.Lte)
1868 :     | PT.And => mkBinopExp(logicalOp2(ty1, ty2), expr1, expr2, Ast.And)
1869 :     | PT.Or => mkBinopExp(logicalOp2(ty1, ty2), expr1, expr2, Ast.Or)
1870 :     | PT.BitOr => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitOr)
1871 :     | PT.BitAnd => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitAnd)
1872 :     | PT.BitXor => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.BitXor)
1873 :     | PT.Lshift => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Lshift)
1874 :     | PT.Rshift => mkBinopExp(integralOp(ty1, ty2), expr1, expr2, Ast.Rshift)
1875 :     | PT.PlusAssign => mkBinaryAssignOpExp(plusOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.PlusAssign, PT.Plus)
1876 :     | PT.MinusAssign => mkBinaryAssignOpExp(minusOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.MinusAssign, PT.Minus)
1877 :     | PT.TimesAssign => mkBinaryAssignOpExp(mulDivOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.TimesAssign, PT.Times)
1878 :     | PT.DivAssign => mkBinaryAssignOpExp(mulDivOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.DivAssign, PT.Divide)
1879 :     | PT.ModAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.ModAssign, PT.Mod)
1880 :     | PT.XorAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.XorAssign, PT.BitXor)
1881 :     | PT.OrAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.OrAssign, PT.BitOr)
1882 :     | PT.AndAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.AndAssign, PT.BitAnd)
1883 :     | PT.LshiftAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.LshiftAssign, PT.Lshift)
1884 :     | PT.RshiftAssign => mkBinaryAssignOpExp(integralOp(ty1, ty2), ty1, expr1, ty2, expr2, Ast.RshiftAssign, PT.Rshift)
1885 :     | PT.OperatorExt binop =>
1886 :     (bug "Operator extension (binop case) should be dealt with at top level case";
1887 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
1888 :    
1889 :     | _ => (bug "[BuildAst.cnvExpression] \
1890 :     \Binary operator expected.";
1891 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
1892 :     end
1893 :    
1894 :     fun processUnop(ty, expr, unop) =
1895 :     let fun simpleUnOp(expop, s) =
1896 :     let val newTy = usualUnaryCnv ty
1897 :     in if perform_type_checking then
1898 :     if isNumber newTy then ()
1899 :     else error ("Type Error: operand of " ^ s ^ " must be a number.")
1900 :     else ();
1901 :     mkUnopExp((ty, newTy), expr, expop)
1902 :     end
1903 :     fun logicalOp1 ty1 = (* Not *)
1904 :     let val stdInt = signedNum Ast.INT
1905 :     in if perform_type_checking then
1906 :     if isNumberOrPointer ty1
1907 :     then (stdInt, stdInt)
1908 :     else
1909 :     (error
1910 :     "Type Error: Unacceptable argument of logical operator.";
1911 :     (ty1, signedNum Ast.INT))
1912 :     else (ty1, signedNum Ast.INT)
1913 :     end
1914 :     in
1915 :     case unop of
1916 :     PT.PostInc => mkUnaryAssignOpExp(plusOp(ty, stdInt), ty, expr, {preOp=false}, Ast.PostInc, PT.Plus)
1917 :     | PT.PreInc => mkUnaryAssignOpExp(plusOp(ty, stdInt), ty, expr, {preOp=true}, Ast.PreInc, PT.Plus)
1918 :     | PT.PostDec => mkUnaryAssignOpExp(minusOp(ty, stdInt), ty, expr, {preOp=false}, Ast.PostDec, PT.Minus)
1919 :     | PT.PreDec => mkUnaryAssignOpExp(minusOp(ty, stdInt), ty, expr, {preOp=true}, Ast.PreDec, PT.Minus)
1920 :     | PT.Uplus => simpleUnOp(Ast.Uplus, "unary op +")
1921 :     | PT.Negate => simpleUnOp(Ast.Negate, "unary op +")
1922 :     | PT.Not => mkUnopExp(logicalOp1 ty, expr, Ast.Not)
1923 :     | PT.BitNot => simpleUnOp(Ast.BitNot, "unary op ~")
1924 :     | _ => (bug "BuildAst.cnvExpression \
1925 :     \Unary operator expected";
1926 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
1927 :     end
1928 :    
1929 :     fun cnvExpr expr = (* returns (Ast.ctype * AST.CoreExpr) *)
1930 :     (case expr
1931 :     of PT.EmptyExpr =>
1932 :     (bug "cnvExpression: PT.EmptyExpr";
1933 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
1934 :     (* DBM: no more Ast.Empty_exp ??? *)
1935 :     | PT.MARKexpression(loc, expr) =>
1936 :     (pushLoc loc;
1937 :     cnvExpression expr
1938 :     before popLoc ())
1939 :     | PT.IntConst i =>
1940 :     wrapEXPR(signedNum Ast.INT, Ast.IntConst i)
1941 :     | PT.RealConst r =>
1942 :     wrapEXPR(signedNum Ast.DOUBLE, Ast.RealConst r)
1943 :     | PT.String s =>
1944 :     let val t = if (!default_signed_char)
1945 :     then signedNum Ast.CHAR
1946 :     else unsignedNum Ast.CHAR
1947 :     val ct = Ast.Pointer t
1948 :     in wrapEXPR(ct,Ast.StringConst s) end
1949 :     | PT.Id s =>
1950 :     (* should id of type function be immediately converted
1951 :     * to pointer to function? *)
1952 :     (case lookSym (Sym.object s)
1953 :     of SOME(ID(id as {ctype=ty,...})) =>
1954 :     wrapEXPR(ty, Ast.Id id)
1955 :     | SOME(MEMBER(member as {ctype=ty,kind,...})) =>
1956 :     (* could it be an enum constant? *)
1957 :     (* note: an enum const is inserted as EnumConst,
1958 :     * but is in same namespace as Object *)
1959 :     (case kind
1960 :     of Ast.ENUMmem i =>
1961 :     wrapEXPR(ty, Ast.EnumId(member,i))
1962 :     | Ast.STRUCTmem =>
1963 :     (error ("struct member used as id: " ^ s);
1964 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
1965 :     | Ast.UNIONmem =>
1966 :     (error ("union member used as id: " ^ s);
1967 :     wrapEXPR(Ast.Error, Ast.ErrorExpr)))
1968 :     | NONE => (* implicit declaration *)
1969 :     let val ty = signedNum Ast.INT
1970 :     val sym = Sym.object s
1971 :     val id = {name = sym, uid = Pid.new(), location = getLoc(),
1972 :     ctype = ty, stClass = Ast.DEFAULT, status = Ast.IMPLICIT,
1973 :     kind = Ast.NONFUN, global = topLevel()}
1974 :     in bindSym(sym, B.ID(id(*,B.OBJ{final=false}*)));
1975 :     (if undeclared_id_error then error else warn)
1976 :     (s ^ " not declared");
1977 :     wrapEXPR(ty, Ast.Id id)
1978 :     end
1979 :     | SOME binding =>
1980 :     (bug ("cnvExpression: bad id binding for "^s) ;
1981 :     debugPrBinding(s,binding);
1982 :     wrapEXPR(Ast.Error, Ast.ErrorExpr)))
1983 :    
1984 :     | PT.Unop (PT.OperatorExt unop, expr) =>
1985 :     CNVUnop {unop=unop, argExpr=expr}
1986 :     | PT.Unop (PT.SizeofType typeName, _) =>
1987 :     let val ty = cnvCtype (false,typeName)
1988 :     in if storage_size_check then
1989 :     if hasKnownStorageSize ty then ()
1990 :     else error "Cannot take sizeof an expression of unknown size."
1991 :     else ();
1992 :     if !reduce_sizeof then
1993 :     let val ast = Ast.IntConst(sizeof ty)
1994 :     in wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
1995 :     ast)
1996 :     end
1997 :     else
1998 :     wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
1999 :     Ast.SizeOf ty)
2000 :     end
2001 :     | PT.Unop (expop, expr_parseTree) =>
2002 :     let val (ty, expr) = cnvExpression (expr_parseTree)
2003 :     (* ASSERT: expr_parseTree cannot be PT.EmptyExpr *)
2004 :     in case expop
2005 :     of PT.Sizeof =>
2006 :     (let fun checkForFun(PT.Id s) =
2007 :     (case lookSym (Sym.object s)
2008 :     of SOME(B.ID{ctype=Ast.Function _,...}) =>
2009 :     error "Cannot take sizeof a function."
2010 :     | _ => ())
2011 :     | checkForFun(PT.MARKexpression(loc, expr)) = checkForFun expr
2012 :     | checkForFun _ = ()
2013 :     in
2014 :     checkForFun expr_parseTree
2015 :     end;
2016 :     if storage_size_check then
2017 :     if hasKnownStorageSize ty then ()
2018 :     else error
2019 :     "Cannot take sizeof an expression of unknown size."
2020 :     else ();
2021 :     if !reduce_sizeof then
2022 :     let val ast = Ast.IntConst(sizeof ty)
2023 :     in
2024 :     wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED), ast)
2025 :     end
2026 :     else
2027 :     wrapEXPR(Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.INT,Ast.SIGNASSUMED),
2028 :     Ast.SizeOf ty)
2029 :     )
2030 :     | PT.AddrOf =>
2031 :     let val coreExpr = getCoreExpr expr
2032 :     val ty =
2033 :     if isLval(coreExpr, ty) then
2034 :     case coreExpr of
2035 :     Ast.Id {ctype=idCtype, stClass, ...} =>
2036 :     (if stClass = Ast.REGISTER
2037 :     then error "Cannot take address of register variable."
2038 :     else ();
2039 :     if isFunction idCtype then ty (* ty already pointer to fn *)
2040 :     else Ast.Pointer ty)
2041 :     | _ => Ast.Pointer ty
2042 :     else (error
2043 :     "Cannot take address of non-lval expression.";
2044 :     Ast.Pointer ty)
2045 :     in
2046 :     wrapEXPR(ty, Ast.AddrOf expr)
2047 :     end
2048 :    
2049 :     (**** old code: delete in due course
2050 :     let fun checkId(PT.Id s) =
2051 :     (case getStorageClass (Sym.object s)
2052 :     of SOME Ast.REGISTER =>
2053 :     error
2054 :     "Cannot take address of register variable."
2055 :     | _ => ();
2056 :     if isFunction ty then
2057 :     (case ty
2058 :     of Ast.Pointer _ => wrapEXPR(ty, getCoreExpr expr)
2059 :     | _ => wrapEXPR(Ast.Pointer ty, getCoreExpr expr))
2060 :     (* Bug fix from Satish: 2/4/99
2061 :     It should be just "ty" in place of "Pointer ty", because we convert
2062 :     all function types to pointer types at the end of cnvExpr, by
2063 :     calling cnvFunctionToPointer2Function.
2064 :     Conservative coding: above deals with case when function may
2065 :     *not* have pointer around it.
2066 :     *)
2067 :     else wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr))
2068 :     | checkId(PT.MARKexpression(loc, expr)) = checkId expr
2069 :     | checkId _ = wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr)
2070 :     in
2071 :     checkId expr_parseTree
2072 :     end
2073 :     else
2074 :     (error
2075 :     "Cannot take address of non-lval expression.";
2076 :     wrapEXPR(Ast.Pointer ty, Ast.AddrOf expr))
2077 :     end old code ******)
2078 :     | PT.Star => wrapEXPR(deref ty, Ast.Deref expr)
2079 :     (* Used to explicitly squash *f, but this is incorrect.
2080 :     Note 1: this happens automatically for type.
2081 :     If I have *f and f has type=pointer(function),
2082 :     then deref ty give us type=function,
2083 :     and then wrapEXPR gives us back pointer(function).
2084 :     Note 2: the real semantic processing of what star
2085 :     achieves operationally is defined in simplify. *)
2086 :     | PT.OperatorExt unop =>
2087 :     (bug "Operator extension (unop case) should be dealt with at top level case";
2088 :     wrapEXPR(Ast.Error, Ast.ErrorExpr))
2089 :    
2090 :     | _ => processUnop(ty, expr, expop)
2091 :     end
2092 :    
2093 :     | PT.Binop (PT.OperatorExt binop, expr1, expr2) =>
2094 :     CNVBinop {binop=binop,
2095 :     arg1Expr=expr1,
2096 :     arg2Expr=expr2}
2097 :     | PT.Binop (expop, expr1, expr2) =>
2098 :     let val (ty1, expr1') = cnvExpression (expr1)
2099 :     in case expop
2100 :     of PT.Dot =>
2101 :     let
2102 :     val s =
2103 :     let fun getId (PT.Id str) = str
2104 :     | getId (PT.MARKexpression(loc, expr)) = getId expr
2105 :     | getId _ = (error "Identifier expected - filling with missing_id";
2106 :     "<missing_id>")
2107 :     in
2108 :     getId expr2
2109 :     end
2110 :    
2111 :     val m as {ctype,...} =
2112 :     (case isStructOrUnion ty1
2113 :     of SOME tid =>
2114 :     let val sym = Sym.member (tid, s)
2115 :     in case lookSym sym
2116 :     of SOME(MEMBER m) => m
2117 :     | _ =>
2118 :     (if isPartial tid then
2119 :     error
2120 :     "Can't access fields in incomplete type."
2121 :     else error ("Field " ^ s ^ " not found.");
2122 :     (* get garbage pid to continue *)
2123 :     bogusMember sym)
2124 :     end
2125 :     | NONE =>
2126 :     (error
2127 :     ("Field " ^ s ^
2128 :     " not found; expression does not have structure \
2129 :     \or union type.");
2130 :     (* get garbage pid to continue *)
2131 :     bogusMember(Sym.member(bogusTid,"s"))))
2132 :     in wrapEXPR(ctype, Ast.Member (expr1', m))
2133 :     end
2134 :     | PT.Arrow =>
2135 :     let
2136 :     val s =
2137 :     let fun getId (PT.Id str) = str
2138 :     | getId (PT.MARKexpression(loc, expr)) = getId expr
2139 :     | getId _ = (error "Identifier expected - filling with missing_id";
2140 :     "<missing_id>")
2141 :     in
2142 :     getId expr2
2143 :     end
2144 :     val tyDeref = deref ty1
2145 :     val m as ({ctype,...}: Ast.member) =
2146 :     (case isStructOrUnion tyDeref
2147 :     of SOME tid =>
2148 :     let val sym = Sym.member (tid, s)
2149 :     in case lookSym sym
2150 :     of SOME(B.MEMBER m) => m
2151 :     | NONE =>
2152 :     (if isPartial tid then
2153 :     error
2154 :     "Can't access fields in incomplete type."
2155 :     else error ("Field " ^ s ^ " not found.");
2156 :     (* get garbage pid to continue *)
2157 :     bogusMember sym)
2158 :     | _ => (error (s^" is not a member");
2159 :     bogusMember sym)
2160 :     end
2161 :     | NONE =>
2162 :     (error
2163 :     ("Field " ^ s ^
2164 :     " not found; expression does not have structure \
2165 :     \or union type.");
2166 :     (* get garbage pid to continue *)
2167 :     bogusMember(Sym.member(bogusTid,"s"))))
2168 :     in wrapEXPR(ctype, Ast.Arrow (expr1', m))
2169 :     end
2170 :     | PT.Sub =>
2171 :     let val (ty2, expr2') = cnvExpression (expr2)
2172 :     val ty =
2173 :     if isPointer ty1 then deref ty1
2174 :     else if isPointer ty2 then deref ty2
2175 :     else (error "Array/ptr expected.";
2176 :     Ast.Error)
2177 :     in wrapEXPR(ty, Ast.Sub (expr1', expr2'))
2178 :     end
2179 :     | PT.Comma =>
2180 :     let val (ty2, expr2') = cnvExpression (expr2)
2181 :     in wrapEXPR(ty2, Ast.Comma (expr1', expr2'))
2182 :     end
2183 :     | PT.Assign =>
2184 :     let val (exprTy, expr2') = cnvExpression (expr2)
2185 :     val _ = checkAssign {lhsTy=ty1, lhsExpr=getCoreExpr expr1',
2186 :     rhsTy=exprTy,
2187 :     rhsExprOpt=SOME(getCoreExpr expr2')}
2188 :     val resultTy = getCoreType ty1
2189 :     val (expr2') = wrapCast (resultTy, expr2')
2190 :     in wrapEXPR(resultTy, Ast.Assign (expr1', expr2'))
2191 :     (* type of result is the unqualified type of the left
2192 :     * operand: H&S p 221. *)
2193 :     end
2194 :     | _ => let val (ty2, expr2') = cnvExpression (expr2)
2195 :     in processBinop (ty1, expr1', ty2, expr2', expop)
2196 :     end
2197 :     end
2198 :     | PT.QuestionColon (expr1, expr2, expr3) =>
2199 :     let
2200 :     val (exprTy, expr1') = cnvExpression (expr1)
2201 :     val _ =
2202 :     if perform_type_checking andalso not(isScalar exprTy)
2203 :     then error
2204 :     "Type Error: condition of question-colon statement is not scalar."
2205 :     else ()
2206 :     val (ty2, expr2') = cnvExpression (expr2)
2207 :     val (ty3, expr3') = cnvExpression (expr3)
2208 :     val ty4 = (case conditionalExp {ty1=ty2,exp1Zero=isZeroExp expr2',
2209 :     ty2=ty3,exp2Zero=isZeroExp expr3'}
2210 :     of SOME ty => ty
2211 :     | NONE =>
2212 :     (error
2213 :     "Type Error: Unacceptable operands of question-colon.";
2214 :     ty2))
2215 :     val (expr2') = wrapCast (ty4, expr2')
2216 :     val (expr3') = wrapCast (ty4, expr3')
2217 :     in
2218 :     wrapEXPR(ty4, Ast.QuestionColon (expr1',expr2',expr3'))
2219 :     end
2220 :     | PT.Call (expr, exprs) =>
2221 :     let
2222 :     val (funTy, expr', prototype) =
2223 :     let fun checkId (PT.Id s) =
2224 :     let val funId as ({ctype=funTy,...}: Ast.id) =
2225 :     (case lookSym (Sym.func s)
2226 :     of SOME(ID id) => id
2227 :     | NONE =>
2228 :     (* if ANSI C then this should be an error... *)
2229 :     let val ty = mkFunctionCt (signedNum Ast.INT,[])
2230 :     val varSym = Sym.object s
2231 :     val id = {name = varSym, uid = Pid.new(),
2232 :     location = getLoc(),status=Ast.IMPLICIT,
2233 :     ctype = ty, stClass = Ast.EXTERN,
2234 :     kind = Ast.FUNCTION{hasFunctionDef=false},
2235 :     global = true} (* is is a function, so it is global! *)
2236 :     val binding = ID id
2237 :     in (* force insertion of symbol at top level *)
2238 :     bindSymGlobal(varSym, binding);
2239 :     (if Config.TypeCheckControl.undeclared_fun_error
2240 :     then error else warn)
2241 :     ("function " ^ s ^ " not declared");
2242 :     id
2243 :     end
2244 :     | _ => (error (s^" is not a function");
2245 :     {name = Sym.func s, uid = Pid.new(),
2246 :     location = SourceMap.UNKNOWN,
2247 :     ctype = Ast.Error, global = topLevel(),
2248 :     stClass = Ast.DEFAULT, status = Ast.IMPLICIT,
2249 :     kind = Ast.FUNCTION{hasFunctionDef=false}}))
2250 :     val adorn = bindAid funTy
2251 :     in (funTy, Ast.EXPR (Ast.Id funId, adorn, getLoc()),
2252 :     isFunctionPrototype funTy)
2253 :     end
2254 :     | checkId(PT.MARKexpression(loc, expr)) =
2255 :     (pushLoc loc;
2256 :     checkId expr
2257 :     before popLoc ())
2258 :     | checkId _ =
2259 :     let val (funTy, expr) = cnvExpression expr
2260 :     val prototype = isFunctionPrototype funTy
2261 :     in (funTy, expr, prototype)
2262 :     end
2263 :     in
2264 :     checkId expr
2265 :     end
2266 :    
2267 :     val tyExprList = List.map cnvExpression exprs
2268 :     val (argTys, exprs) = ListPair.unzip tyExprList
2269 :    
2270 :     fun cnvArgs (expr :: exprs, ty :: tys) =
2271 :     let val (expr) = wrapCast (ty, expr)
2272 :     val (exprs) = cnvArgs (exprs, tys)
2273 :     in expr :: exprs
2274 :     end
2275 :     | cnvArgs (nil, nil) = nil
2276 :     | cnvArgs _ =
2277 :     (bug "type list and expression list must be same size";
2278 :     nil)
2279 :    
2280 :     val (retTy, exprs) =
2281 :     if perform_type_checking
2282 :     then if prototype
2283 :     then let val (retTy, cnvArgTys) =
2284 :     checkFn (funTy, argTys, exprs)
2285 :     val (exprs) = cnvArgs (exprs, cnvArgTys)
2286 :     in (retTy, exprs)
2287 :     end
2288 :     else let val cnvArgTys = List.map (functionArgConv) argTys
2289 :     val retTy =
2290 :     case getFunction funTy
2291 :     of SOME(retTy,_) => retTy
2292 :     | NONE =>
2293 :     (error
2294 :     "Called object is not a function.";
2295 :     Ast.Error)
2296 :     val (exprs) = cnvArgs (exprs, cnvArgTys)
2297 :     in (retTy, exprs)
2298 :     end
2299 :     else let val retTy = case getFunction funTy
2300 :     of SOME(retTy,_) => retTy
2301 :     | NONE => Ast.Void
2302 :     in (retTy, exprs)
2303 :     end
2304 :     in
2305 :     wrapEXPR(retTy, Ast.Call(expr', exprs))
2306 :     end
2307 :     | PT.Cast (ct, expr) => (* TODO: should check consistency of cast *)
2308 :     let val ty = cnvCtype (false, ct)
2309 :     val (_, expr') = cnvExpression expr
2310 :     in wrapEXPR(ty, Ast.Cast (ty, expr'))
2311 :     end
2312 :     | PT.InitList exprs =>
2313 :     let fun process e = #2(cnvExpression e)
2314 :     val exprs = List.map process exprs
2315 :     in (* PT.InitList should only occur within declarators as
2316 :     * an aggregate initializer. It is handled in processDecr. *)
2317 :     bug "cnvExpression: unexpected InitList";
2318 :     wrapEXPR(Ast.Error, Ast.ErrorExpr)
2319 :     end
2320 :    
2321 :     | PT.ExprExt expr => CNVExp expr
2322 :     )
2323 :     in cnvExpr expr
2324 :     end
2325 :    
2326 :     (* --------------------------------------------------------------------
2327 :     * cnvType : bool * PT.ctype -> Ast.ctype
2328 :     *
2329 :     * Converts a parse-tree type into an ast type, adding new type and
2330 :     * symbol (e.g. enumerated values and field identifiers) into the
2331 :     * environment.
2332 :     *
2333 :     * The boolean first argument is a flag indicating if this type is a
2334 :     * `shadow' - that is a struct/enum/union tag type used to refer
2335 :     * to a future struct/union/enum declaration rather than one defined in
2336 :     * an outer scope.
2337 :     *
2338 :     * Named types (i.e. structs/unions/enums/typedefs) are represented by
2339 :     * indexes into the named-type table. That table maps these indexes to
2340 :     * the actual struct/union/enum/typedef. This allows for for such a
2341 :     * type to be resolved without having to do multiple enquiries into the
2342 :     * symbol-table stack. By convention, an explicitly tagged type will be
2343 :     * stored redundantly in the symbol table: once as its explicit tag and
2344 :     * once as a manufactured one corresponding to the unique named type id
2345 :     * generated by Tidtab.new.
2346 :     * -------------------------------------------------------------------- *)
2347 :    
2348 :     and cnvCtype (isShadow: bool, ty: PT.ctype) : Ast.ctype =
2349 :     let fun cnvSpecifier specifiers =
2350 :     let val signed = ref (NONE : Ast.signedness option)
2351 :     val frac = ref (NONE : Ast.fractionality option)
2352 :     val sat = ref (NONE : Ast.saturatedness option)
2353 :     val kind = ref (NONE : Ast.intKind option)
2354 :     fun cnvSpecList (spec :: specL) =
2355 :     (case spec
2356 :     of PT.Signed =>
2357 :     (case !kind
2358 :     of SOME (Ast.FLOAT | Ast.DOUBLE | Ast.LONGDOUBLE) =>
2359 :     error "illegal combination of signed with float/double/long double"
2360 :     | _ => ();
2361 :     case !signed
2362 :     of NONE => (signed := SOME Ast.SIGNED)
2363 :     | SOME _ => error "Multiple signed/unsigned")
2364 :     | PT.Unsigned =>
2365 :     (case !kind
2366 :     of SOME (Ast.FLOAT | Ast.DOUBLE | Ast.LONGDOUBLE) =>
2367 :     error "illegal combination of unsigned with float/double/long double"
2368 :     | _ => ();
2369 :     case !signed
2370 :     of NONE => (signed := SOME Ast.UNSIGNED)
2371 :     | SOME _ => error "Multiple signed/unsigned")
2372 :     | PT.Char =>
2373 :     (case !kind
2374 :     of NONE => (kind := SOME Ast.CHAR)
2375 :     | SOME ct =>
2376 :     error (case ct
2377 :     of Ast.CHAR => "duplicate char specifier"
2378 :     | _ => "illegal use of char specifier"))
2379 :     | PT.Short =>
2380 :     (case !kind
2381 :     of (NONE | SOME Ast.INT) => (kind := SOME Ast.SHORT)
2382 :     | SOME ct =>
2383 :     error (case ct
2384 :     of Ast.SHORT => "duplicate short specifier"
2385 :     | _ => "illegal use of short specifier"))
2386 :     | PT.Int =>
2387 :     (case !kind
2388 :     of NONE => (kind := SOME Ast.INT)
2389 :     | SOME (Ast.SHORT | Ast.LONG | Ast.LONGLONG) => ()
2390 :     | SOME ct =>
2391 :     error (case ct
2392 :     of Ast.INT => "duplicate int specifier"
2393 :     | _ => "illegal use of int specifier"))
2394 :     | PT.Long =>
2395 :     (case !kind
2396 :     of NONE => (kind := SOME Ast.LONG)
2397 :     | SOME Ast.LONG => (kind := SOME Ast.LONGLONG)
2398 :     | SOME Ast.INT => (kind := SOME Ast.LONG)
2399 :     | SOME ct =>
2400 :     error (case ct
2401 :     of Ast.LONGLONG => "triplicate long specifier"
2402 :     | _ => "illegal use of long specifier"))
2403 :     | PT.Float =>
2404 :     (case !signed
2405 :     of NONE => ()
2406 :     | SOME _ => error "illegal combination of signed/unsigned with float";
2407 :     case !kind
2408 :     of NONE => (kind := SOME Ast.FLOAT)
2409 :     | SOME ct =>
2410 :     error (case ct
2411 :     of Ast.FLOAT => "duplicate float specifier"
2412 :     | _ => "illegal use of float specifier"))
2413 :     | PT.Double =>
2414 :     (case !signed
2415 :     of NONE => ()
2416 :     | SOME _ => error "illegal combination of signed/unsigned with double";
2417 :     case !kind
2418 :     of NONE => (kind := SOME Ast.DOUBLE)
2419 :     | SOME Ast.LONG => (kind := SOME Ast.LONGDOUBLE)
2420 :     | SOME ct =>
2421 :     error (case ct
2422 :     of Ast.DOUBLE => "duplicate double specifier"
2423 :     | _ => "illegal use of double specifier"))
2424 :     | PT.Fractional =>
2425 :     (case !frac
2426 :     of NONE => (frac := SOME Ast.FRACTIONAL)
2427 :     | SOME _ => error "Multiple fractional or wholenum")
2428 :     | PT.Wholenum =>
2429 :     (case !frac
2430 :     of NONE => (frac := SOME Ast.WHOLENUM)
2431 :     | SOME _ => error "Multiple fractional or wholenum")
2432 :     | PT.Saturate =>
2433 :     (case !sat
2434 :     of NONE => (sat := SOME Ast.SATURATE)
2435 :     | SOME _ => error "Multiple saturate or nonsaturate")
2436 :     | PT.Nonsaturate =>
2437 :     (case !sat
2438 :     of NONE => (sat := SOME Ast.NONSATURATE)
2439 :     | SOME _ => error "Multiple saturate or nonsaturate")
2440 :     | _ => error("Illegal combination of type specifiers.");
2441 :     cnvSpecList specL)
2442 :     | cnvSpecList [] =
2443 :     let val numKind = case !kind
2444 :     of NONE => Ast.INT
2445 :     | SOME numKind => numKind
2446 :     val frac = case !frac
2447 :     of NONE => Ast.WHOLENUM
2448 :     | SOME frac => frac
2449 :     val (sign,decl)
2450 :     = case (!signed, numKind)
2451 :     of (NONE, Ast.CHAR) =>
2452 :     if (!default_signed_char)
2453 :     then (Ast.SIGNED, Ast.SIGNASSUMED)
2454 :     else (Ast.UNSIGNED, Ast.SIGNASSUMED)
2455 :     (* according to H&S p115,
2456 :     * char can be signed or unsigned *)
2457 :     | (NONE, _) => (Ast.SIGNED, Ast.SIGNASSUMED)
2458 :     | (SOME sign, _) => (sign, Ast.SIGNDECLARED)
2459 :     val sat = case !sat
2460 :     of NONE => Ast.NONSATURATE
2461 :     | SOME sat => sat
2462 :     in
2463 :     Ast.Numeric (sat,frac,sign,numKind,decl)
2464 :     end
2465 :     fun noMore [] _ = ()
2466 :     | noMore _ err = error (err ^ " cannot be combined with a specifier.")
2467 :     in case specifiers
2468 :     (* singleton cases: these should appear solo *)
2469 :     of PT.Void :: l => (noMore l "Void"; Ast.Void)
2470 :     | PT.Ellipses :: l => (noMore l "Ellipse"; Ast.Ellipses)
2471 :     | (PT.Array (expr, ty)) :: l =>
2472 :     let val _ = noMore l "Array"
2473 :     val opt = case expr of
2474 :     PT.EmptyExpr => NONE
2475 :     | _ => (case evalExpr expr of (* cannot be EmptyExpr *)
2476 :     (SOME i, _, expr', _) =>
2477 :     (if i=0 then warn "Array has zero size." else ();
2478 :     SOME(i, expr'))
2479 :     | (NONE, _, expr', _) => (error "Array size must be constant expression.";
2480 :     SOME(0, expr')))
2481 :     val ty' = cnvCtype (false, ty)
2482 :     in Ast.Array (opt, ty')
2483 :     end
2484 :     | (PT.Pointer ty) :: l =>
2485 :     let val _ = noMore l "Pointer"
2486 :     val ty' = cnvCtype (false, ty)
2487 :     in Ast.Pointer ty'
2488 :     end
2489 :     | (PT.Function {retType,params}) :: l =>
2490 :     let val _ = noMore l "Function"
2491 :     val retTy = cnvCtype (false, retType)
2492 :     fun process (dt, decl) =
2493 :     let
2494 :     (*dpo: ignore storage class in translating type *)
2495 :     val ty = (dt2ct o #1) (processDeclarator (dt, decl))
2496 :     val ty = cnvCtype (false, ty)
2497 :     in
2498 :     ty
2499 :     end
2500 :     val argTys = List.map process params
2501 :     in mkFunctionCt (retTy, argTys)
2502 :     end
2503 :    
2504 :     (* ------------- Enumerated Types ----------------
2505 :     * If enum tag is explicitly mentioned:
2506 :     * if partially defined then use that named type
2507 :     * identifier;
2508 :     * otherwise, if it has never been mentioned or if
2509 :     * it has been mentioned for a completely defined
2510 :     * type (so that this definition is new for an
2511 :     * inner scope) then create a new named type id
2512 :     * and store a reference to it in the current
2513 :     * symbol table.
2514 :     * Otherwise, this is an `anonynmous' enum type: create a
2515 :     * new named type id and store a reference to it in the
2516 :     * current symbol table.
2517 :     *)
2518 :    
2519 :     | (PT.Enum {tagOpt,enumerators,trailingComma}) :: l =>
2520 :     let
2521 :     val _ = noMore l "Enum"
2522 :     (* check for trailing comma warning/error *)
2523 :     val _ =
2524 :     if trailingComma then
2525 :     if #error Config.ParseControl.trailingCommaInEnum
2526 :     then error "trailing comma in enum declaration"
2527 :     else if #warning Config.ParseControl.trailingCommaInEnum
2528 :     then warn "trailing comma in enum declaration"
2529 :     else ()
2530 :     else ()
2531 :     val (tid, alreadyDefined) =
2532 :     (* alreadyDefined for multi-file analysis mode *)
2533 :     (case tagOpt
2534 :     of SOME tagname =>
2535 :     let
2536 :     val sym = Sym.tag tagname
2537 :     val tidFlagOpt =
2538 :     (case lookLocalScope sym
2539 :     of SOME(TAG{ctype=ty,location=loc',...}) =>
2540 :     (case ty
2541 :     of Ast.EnumRef tid =>
2542 :     if isPartial tid
2543 :     then SOME{tid=tid, alreadyDefined=false}
2544 :     else if repeated_declarations_ok
2545 :     then SOME{tid=tid, alreadyDefined=true}
2546 :     else
2547 :     (error
2548 :     ("Redeclaration of enum tag `" ^
2549 :     tagname ^
2550 :     "'; previous declaration at " ^
2551 :     SM.locToString loc');
2552 :     NONE)
2553 :     | _ =>
2554 :     (error
2555 :     ("Redeclaration of enum tag `" ^
2556 :     tagname ^
2557 :     "'; previous declaration was not an " ^
2558 :     "enum tag and appeared at " ^
2559 :     SM.locToString loc');
2560 :     NONE))
2561 :     | NONE => NONE
2562 :     | _ => (error (tagname^ " is not an enum tag");
2563 :     NONE))
2564 :     in case tidFlagOpt
2565 :     of SOME{tid, alreadyDefined} =>
2566 :     (tid, alreadyDefined)
2567 :     | NONE =>
2568 :     let val tid = Tid.new ()
2569 :     val ty = Ast.EnumRef tid
2570 :     in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2571 :     location=getLoc(), ctype=ty});
2572 :     bindTid (tid, {name=tagOpt, ntype=NONE,
2573 :     global=topLevel(), location=getLoc()});
2574 :     (tid, false)
2575 :     end
2576 :     end
2577 :     | NONE =>
2578 :     let val (tid,alreadyDefined) =
2579 :     if !multi_file_mode andalso (topLevel ()) then
2580 :     (* in multi_file_mode, give identical top-level
2581 :     * enums the same tid *)
2582 :     case AnonymousStructs.findAnonStructEnum ty
2583 :     of SOME tid => (tid,true)
2584 :     | NONE =>
2585 :     let val tid = Tid.new ()
2586 :     in AnonymousStructs.addAnonTid(ty, tid);
2587 :     (tid,false)
2588 :     end
2589 :     else
2590 :     let val tid = Tid.new ()
2591 :     (* in standard mode, allocate new tid *)
2592 :     in (tid, false)
2593 :     end
2594 :     in if alreadyDefined then ()
2595 :     else bindTid (tid, {name=tagOpt, ntype=NONE,
2596 :     global=topLevel(), location=getLoc()});
2597 :     (tid, alreadyDefined)
2598 :     end)
2599 :    
2600 :     (* add each enum value into symbol table (and evaluate it);
2601 :     prevVal passes the enum value from one enum entry to the next
2602 :     so that
2603 :     enum {e1,e2,e3=4,e4};
2604 :     gives
2605 :     enum {e1=0,e2=1,e3=4,e4=5};
2606 :     *)
2607 :     fun process prevVal nil = nil
2608 :     | process prevVal ((name,e) :: l) =
2609 :     let val constValOpt =
2610 :     case e of
2611 :     PT.EmptyExpr => NONE
2612 :     | _ => (case evalExpr e of
2613 :     (SOME i, _, _, sizeofFl) =>
2614 :     (if sizeofFl andalso not(!reduce_sizeof)
2615 :     then warn("sizeof in enum value " ^
2616 :     "not preserved in source-to-source mode.")
2617 :     else ();
2618 :     SOME i)
2619 :     | (NONE, _, _, _) =>
2620 :     (error "Enum value must be constant expression.";
2621 :     NONE))
2622 :     val constVal =
2623 :     case constValOpt
2624 :     of SOME n => n
2625 :     | NONE => prevVal + 1
2626 :     val sym = Sym.enumConst name
2627 :     val ty = Ast.EnumRef tid
2628 :     val _ = checkNonIdRebinding(sym, ty, "enum constant ")
2629 :    
2630 :     val member = {name = sym, uid = Pid.new(),
2631 :     location = getLoc(), ctype=ty,
2632 :     kind = Ast.ENUMmem constVal}
2633 :     val binding = B.MEMBER member
2634 :    
2635 :     val _ = bindSym (sym, binding)
2636 :     in
2637 :     (member, constVal) :: (process constVal l)
2638 :     end
2639 :     in if alreadyDefined then ()
2640 :     else
2641 :     let val idIntList = process (LargeInt.fromInt ~1) enumerators
2642 :     val namedTy = B.Enum (tid,idIntList)
2643 :     in bindTid (tid, {name=tagOpt, ntype=SOME namedTy,
2644 :     global=topLevel(), location=getLoc()});
2645 :     pushTids tid
2646 :     end;
2647 :     Ast.EnumRef tid
2648 :     end
2649 :    
2650 :    
2651 :     (* ------------- Structs and Unions ----------------
2652 :     * Very similar to rules for converting enums. *)
2653 :     | (PT.Struct {isStruct, tagOpt, members}) :: l =>
2654 :     let val _ = noMore l "Struct"
2655 :     val (tid, alreadyDefined) =
2656 :     (case tagOpt
2657 :     of SOME tagname =>
2658 :     let
2659 :     val sym = Sym.tag tagname
2660 :     val tidFlagOpt =
2661 :     (case lookLocalScope sym
2662 :     of SOME(TAG{ctype=ty,location=loc',...}) =>
2663 :     (case ty
2664 :     of (Ast.UnionRef tid | Ast.StructRef tid) =>
2665 :     if isPartial tid
2666 :     then SOME{tid=tid, alreadyDefined=false}
2667 :     else if repeated_declarations_ok
2668 :     then SOME{tid=tid, alreadyDefined=true}
2669 :     else (error("Redeclaration of type tag `"
2670 :     ^ tagname
2671 :     ^ "'; previous declaration at "
2672 :     ^ SM.locToString loc');
2673 :     NONE)
2674 :     | _ =>
2675 :     (error("Redeclaration of type tag `"
2676 :     ^ tagname ^
2677 :     "'; previous declaration was not a "
2678 :     ^ "type tag and appeared at "
2679 :     ^ SM.locToString loc');
2680 :     NONE))
2681 :     | NONE => NONE
2682 :     | _ => (bug "cnvExpression: tag symbol 2"; NONE))
2683 :     in case tidFlagOpt
2684 :     of SOME{tid, alreadyDefined} =>
2685 :     (tid, alreadyDefined)
2686 :     | NONE => (* create a partial tid *)
2687 :     let val tid = Tid.new ()
2688 :     val ty = if isStruct then Ast.StructRef tid
2689 :     else Ast.UnionRef tid
2690 :     in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2691 :     location=getLoc(),
2692 :     ctype=ty});
2693 :     bindTid(tid, {name=NONE, ntype=NONE,
2694 :     global=topLevel(), location=getLoc()});
2695 :     (tid, false)
2696 :     end
2697 :     end
2698 :     | NONE =>
2699 :     let
2700 :     val (tid,alreadyDefined) =
2701 :     if !multi_file_mode andalso (topLevel ()) then
2702 :     (* in multi_file_mode, give identical top-level
2703 :     * structs the same tid
2704 :     *)
2705 :     case AnonymousStructs.findAnonStructEnum ty
2706 :     of SOME tid => (tid, true)
2707 :     | NONE =>
2708 :     let val tid = Tid.new ()
2709 :     in AnonymousStructs.addAnonTid(ty, tid);
2710 :     (tid, false)
2711 :     end
2712 :     else
2713 :     let val tid = Tid.new ()
2714 :     in (tid,false)
2715 :     end
2716 :     in if alreadyDefined then ()
2717 :     else bindTid (tid, {name=NONE, ntype=NONE,
2718 :     global=topLevel(), location=getLoc()});
2719 :     (tid, alreadyDefined)
2720 :     end)
2721 :    
2722 :     (* add members to symbol table, evaluate bit fields
2723 :     * when present *)
2724 :     fun process1 (ct, declExprs) =
2725 :     let
2726 :     val ty = cnvCtype (false, ct)
2727 :     fun process2 (decr,expr)
2728 :     : Ast.ctype * Ast.member option * Int32.int option =
2729 :     let
2730 : dbm 639 val (ty', memNameOpt, loc) = mungeTyDecr (ty, decr)
2731 : dbm 597 val sizeOpt =
2732 :     case expr of
2733 :     PT.EmptyExpr => NONE
2734 :     | _ => (case evalExpr expr of
2735 :     (SOME i, _, _, false) => SOME i
2736 :     | (SOME i, _, _, true) =>
2737 :     (if !reduce_sizeof then ()
2738 :     else warn ("sizeof in bitfield specification " ^
2739 :     "not preserved in source-to-source mode");
2740 :     SOME i)
2741 :     | (NONE, _, _, _) =>
2742 :     (error "Bitfield size must be constant expression";
2743 :     NONE))
2744 :     val memberOpt : Ast.member option =
2745 :     (case memNameOpt
2746 :     of SOME id' =>
2747 :     let val sym = Sym.member (tid,id')
2748 :     val _ =
2749 :     checkNonIdRebinding(sym, ty',
2750 :     "struct/union member ");
2751 :     val _ =
2752 :     if isPartialTy ty'
2753 :     then error("Member `" ^ id'
2754 :     ^ "' has incomplete type.")
2755 :     else ();
2756 :     val _ =
2757 :     if isNonPointerFunction ty'
2758 :     then error("Member `" ^ id'
2759 :     ^ "' has function type.")
2760 :     else ();
2761 :     val member = {name = sym,
2762 :     uid = Pid.new(),
2763 : dbm 639 location = loc,
2764 : dbm 597 ctype = ty',
2765 :     kind = if isStruct
2766 :     then Ast.STRUCTmem
2767 :     else Ast.UNIONmem}
2768 :     in bindSym(sym,MEMBER member);
2769 :     SOME member
2770 :     (* DBM: FIELDs? *)
2771 :     end
2772 :     | NONE => NONE)
2773 :     in (ty', memberOpt, sizeOpt)
2774 :     end (* fun process2 *)
2775 :     in map process2 declExprs
2776 :     end (* fun process1 *)
2777 :    
2778 :     (* union members are more restricted than struct members *)
2779 :     fun checkUnionMember (ty: Ast.ctype, NONE: Ast.member option,
2780 :     _ : Int32.int option) =
2781 :     (error "union member has no name";
2782 :     (ty,bogusMember(Sym.member(tid,"<noname>"))))
2783 :     | checkUnionMember (ty,SOME m,SOME _) =
2784 :     (error "union member has size spec";
2785 :     (ty,m))
2786 :     | checkUnionMember (ty,SOME m,NONE) = (ty,m)
2787 :    
2788 :     in if alreadyDefined then ()
2789 :     else
2790 :     let val members = List.map process1 members
2791 :     val members = List.concat members
2792 :     val namedTy =
2793 :     if isStruct then B.Struct(tid, members)
2794 :     else B.Union(tid, map checkUnionMember members)
2795 :     val binding : B.tidBinding =
2796 :     {name = tagOpt, ntype = SOME namedTy,
2797 :     global = topLevel(), location = getLoc()}
2798 :     in bindTid (tid, binding);
2799 :     pushTids tid
2800 :     end;
2801 :     (if isStruct then Ast.StructRef else Ast.UnionRef) tid
2802 :     end
2803 :    
2804 :     | (PT.TypedefName s) :: l =>
2805 :     (* type symbol is added at the point of declaration: see
2806 :     * cnvExternalDecl (case ExternalDecl(TypeDecl) and cnvStatement (case
2807 :     * Decl(TypeDecl) *)
2808 :     (noMore l "Typedef";
2809 :     case lookSym (Sym.typedef s)
2810 :     of SOME(TYPEDEF{ctype,...}) => ctype
2811 :     | _ => (error("typedef " ^ s ^ " has not been defined.");
2812 :     Ast.Error))
2813 :    
2814 :     | (PT.StructTag {isStruct,name=s}) :: l =>
2815 :     let val _ = noMore l "Struct"
2816 :     val sym = Sym.tag s
2817 :     val tyOpt =
2818 :     case lookSym sym
2819 :     of SOME(TAG{ctype,...}) => SOME ctype
2820 :     | NONE => NONE
2821 :     | _ => (bug "cnvExpression: bad tag 3"; NONE)
2822 :     in if not (isSome tyOpt) orelse
2823 :     (isShadow andalso not (isLocalScope sym)) then
2824 :     let val tid = Tid.new ()
2825 :     val ty = (if isStruct then Ast.StructRef else Ast.UnionRef) tid
2826 :     in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2827 :     location=getLoc(), ctype=ty});
2828 :     bindTid (tid, {name=SOME s, ntype=NONE,
2829 :     global=topLevel(), location=getLoc()});
2830 :     ty
2831 :     end
2832 :     else valOf tyOpt (* guaranteed to be SOME *)
2833 :     end
2834 :    
2835 :     | (PT.EnumTag s) :: l => (* nearly idenitical to struct tag case *)
2836 :     let val _ = noMore l "Enum"
2837 :     val sym = Sym.tag s
2838 :     val tyOpt =
2839 :     case lookSym sym
2840 :     of SOME(TAG{ctype,...}) => SOME ctype
2841 :     | NONE => (if TypeCheckControl.partial_enum_error
2842 :     then error("incomplete enum " ^ s)
2843 :     else ();
2844 :     NONE)
2845 :     | _ => (bug "cnvExpression: bad tag 3"; NONE)
2846 :     in if not (isSome tyOpt) orelse
2847 :     (isShadow andalso not (isLocalScope sym)) then
2848 :     (* if this is explicitly a shadow or a enum tag not seen
2849 :     * before then create a new named type identifier and
2850 :     * record that this type is partially (incompletely)
2851 :     * defined *)
2852 :     let val tid = Tid.new ()
2853 :     val ty = Ast.EnumRef tid
2854 :     in bindSym(sym, TAG{name=sym,uid=Pid.new(),
2855 :     location=getLoc(), ctype=ty});
2856 :     bindTid (tid, {name=SOME s, ntype=NONE,
2857 :     global=topLevel(), location=getLoc()});
2858 :     ty
2859 :     end
2860 :     (* otherwise return the type already established in
2861 :     * environment *)
2862 :     else valOf tyOpt
2863 :     end
2864 :    
2865 :     | (PT.SpecExt xspec) :: rest =>
2866 :     CNVSpecifier {isShadow=isShadow, rest=rest} xspec
2867 :     | l => cnvSpecList l
2868 :     end
2869 :    
2870 :     val {qualifiers, specifiers} = ty
2871 :     in cnvQualifiers (cnvSpecifier specifiers) qualifiers
2872 :     end
2873 :    
2874 :     and cnvType (isShadow: bool, {storage,qualifiers,specifiers}: PT.decltype)
2875 :     : Ast.ctype * Ast.storageClass =
2876 :     let val sc = cnvStorage storage
2877 :     val ct = cnvCtype (isShadow,{qualifiers=qualifiers,specifiers=specifiers})
2878 :     in (ct,sc)
2879 :     end
2880 :    
2881 :     and cnvQualifiers ty [] = ty
2882 :     | cnvQualifiers ty [PT.CONST] = Ast.Qual (Ast.CONST, ty)
2883 :     | cnvQualifiers ty [PT.VOLATILE] = Ast.Qual (Ast.VOLATILE, ty)
2884 :     | cnvQualifiers ty (PT.VOLATILE :: PT.VOLATILE :: _) =
2885 :     (error "Duplicate `volatile'."; ty)
2886 :     | cnvQualifiers ty (PT.CONST :: PT.CONST :: _) =
2887 :     (error "Duplicate 'const'."; ty)
2888 :     | cnvQualifiers ty (_ :: _ :: _ :: _) =
2889 :     (error "too many 'const/volatile' qualifiers."; ty)
2890 :     (* See: ISO-C Standard, p. 64 for meaning of const volatile. *)
2891 :     | cnvQualifiers ty (_ :: _ :: nil) = ty
2892 :    
2893 :    
2894 :    
2895 :     (* --------------------------------------------------------------------
2896 :     * cnvStorage : PT.storage list -> Ast.storageClass option
2897 :     *
2898 :     * Converts a parse-tree storage class into an ast storage class. The
2899 :     * only subtlety is the case where no parse-tree storage class has been
2900 :     * given in which case the default (supplied by second argument) ast
2901 :     * storage class is used.
2902 :     *
2903 :     * For rules for storage classes, see K&R A8.1
2904 :     * -------------------------------------------------------------------- *)
2905 :    
2906 :     and cnvStorage [] = Ast.DEFAULT
2907 :     | cnvStorage [PT.STATIC] = Ast.STATIC
2908 :     | cnvStorage [PT.EXTERN] = Ast.EXTERN
2909 :     | cnvStorage [PT.REGISTER] = Ast.REGISTER
2910 :     | cnvStorage [PT.AUTO] = Ast.AUTO
2911 :     | cnvStorage [PT.TYPEDEF] =
2912 :     (error "illegal use of TYPEDEF";
2913 :     Ast.DEFAULT)
2914 :     | cnvStorage _ =
2915 :     (error "Declarations can contain at most one storage class\
2916 :     \ (static, extern, register, auto).";
2917 :     Ast.DEFAULT)
2918 :    
2919 :     (* --------------------------------------------------------------------
2920 :     * evalExpr : ParseTree expr -> int option
2921 :     *
2922 :     * Converts parse-tree expressions to integer constants where possible;
2923 :     * NONE used for cases where no constant can be computed or when no
2924 :     * expression is given. A new environment is returned because it is
2925 :     * possible to embed definitions of struct/union/enum types within
2926 :     * sizeofs and casts.
2927 :     * -------------------------------------------------------------------- *)
2928 :    
2929 :     and evalExpr e = (* evalExpr should not be called with PT.EmptyExpr *)
2930 :     let
2931 :     val encounteredSizeof = ref false
2932 :     val (eTy, e') = cnvExpression (e)
2933 :     fun evalAstExpr (Ast.EXPR (coreExpr,adorn, _)) =
2934 :     case coreExpr
2935 :     of Ast.IntConst i => SOME i
2936 :     | Ast.Unop (unop, e) => evalUnaryOp (unop, e)
2937 :     | Ast.Binop (binop, e, e') => evalBinaryOp (binop, e, e')
2938 :     | Ast.QuestionColon (e0,e1,e2) =>
2939 :     (case evalAstExpr e0
2940 :     of SOME 0 => evalAstExpr e2
2941 :     | SOME _ => evalAstExpr e1
2942 :     | NONE => NONE)
2943 :     | Ast.Cast (ct,e) =>
2944 :     let val eTy = lookAid adorn
2945 :     in if compatible (ct, eTy) then ()
2946 :     else warn "evalExpr: cast not handled yet";
2947 :     evalAstExpr e
2948 :     end
2949 :     | Ast.EnumId (_, i) => SOME i
2950 :     | Ast.SizeOf ct => (encounteredSizeof := true;
2951 :     SOME(sizeof ct))
2952 :     | _ => NONE
2953 :    
2954 :     and evalBinaryOp (binop, e, e') =
2955 :     let val opt = evalAstExpr e
2956 :     val opt' = evalAstExpr e'
2957 :     in
2958 :     if isSome opt andalso isSome opt' then
2959 :     let val i = valOf opt
2960 :     val i' = valOf opt'
2961 :     in case binop
2962 :     of Ast.Plus => SOME (i + i')
2963 :     | Ast.Minus => SOME (i - i')
2964 :     | Ast.Times => SOME (i * i')
2965 :     | Ast.Divide => SOME (LargeInt.quot (i,i'))
2966 :     | Ast.Mod => SOME (LargeInt.rem (i,i'))
2967 :     | Ast.Gt => SOME (if i > i' then 1 else 0)
2968 :     | Ast.Lt => SOME (if i < i' then 1 else 0)
2969 :     | Ast.Gte => SOME (if i >= i' then 1 else 0)
2970 :     | Ast.Lte => SOME (if i <= i' then 1 else 0)
2971 :     | Ast.Eq => SOME (if i = i' then 1 else 0)
2972 :     | Ast.Neq => SOME (if i <> i' then 1 else 0)
2973 :     | Ast.And => SOME (if i<>0 andalso i'<>0 then 1 else 0)
2974 :     | Ast.Or => SOME (if i<>0 orelse i'<>0 then 1 else 0)
2975 :     | Ast.BitOr =>
2976 :     SOME (W.toLargeInt (W.orb (W.fromLargeInt i, W.fromLargeInt i')))
2977 :     | Ast.BitXor =>
2978 :     SOME (W.toLargeInt (W.xorb (W.fromLargeInt i, W.fromLargeInt i')))
2979 :     | Ast.BitAnd =>
2980 :     SOME (W.toLargeInt (W.andb (W.fromLargeInt i, W.fromLargeInt i')))
2981 :     | Ast.Lshift =>
2982 :     SOME (W.toLargeInt (W.<< (W.fromLargeInt i, W.fromLargeInt i')))
2983 :     | Ast.Rshift =>
2984 :     SOME (W.toLargeInt (W.>> (W.fromLargeInt i, W.fromLargeInt i')))
2985 :     | _ => NONE
2986 :     end
2987 :     else
2988 :     NONE
2989 :     end
2990 :    
2991 :     and evalUnaryOp (unop, e) =
2992 :     let
2993 :     val opt = evalAstExpr e
2994 :     in
2995 :     if isSome opt then
2996 :     let
2997 :     val i = valOf opt
2998 :     in case unop
2999 :     of Ast.Negate => SOME (~i)
3000 :     | Ast.Not => SOME (if i = 0 then 1 else 0)
3001 :     | Ast.Uplus => SOME i
3002 :     | Ast.BitNot => SOME (W.toLargeInt (W.notb (W.fromLargeInt i)))
3003 :     | _ => NONE
3004 :     end
3005 :     else NONE
3006 :     end
3007 :     in (evalAstExpr e', eTy, e', !encounteredSizeof)
3008 :     end
3009 :    
3010 :     (* --------------------------------------------------------------------
3011 :     * makeAst' : ParseTree.external_decl list * Error.errorState -> Ast.ast
3012 :     *
3013 :     * Converts a parse tree into an ast, by recursively converting
3014 :     * each delcaration in the list.
3015 :     * -------------------------------------------------------------------- *)
3016 :    
3017 :     (* initializing extension conversion functions *)
3018 :    
3019 :     val _ =
3020 :     let val coreFuns = {stateFuns=stateFuns,
3021 : dbm 639 mungeTyDecr=(fn (ty, decr) =>
3022 :     let val (ctype, name, _) =
3023 :     mungeTyDecr(ty,decr)
3024 :     in (ctype, name) end),
3025 :     (* since we added location in the output of mungeTyDecr and
3026 :     * we don't want to change the extension interface *)
3027 : dbm 597 cnvType=cnvType,
3028 :     cnvExpression=cnvExpression,
3029 :     cnvStatement=cnvStatement,
3030 :     cnvExternalDecl=cnvExternalDecl,
3031 :     wrapEXPR=wrapEXPR,
3032 :     wrapSTMT=wrapSTMT,
3033 :     wrapDECL=wrapDECL}
3034 :     val {CNVExp, CNVStat, CNVBinop, CNVUnop, CNVExternalDecl,
3035 :     CNVSpecifier, CNVDeclarator, CNVDeclaration} = CnvExt.makeExtensionFuns coreFuns
3036 :     in
3037 :     refCNVExp := CNVExp;
3038 :     refCNVStat := CNVStat;
3039 :     refCNVBinop := CNVBinop;
3040 :     refCNVUnop := CNVUnop;
3041 :     refCNVExternalDecl := CNVExternalDecl;
3042 :     refCNVSpecifier := CNVSpecifier;
3043 :     refCNVDeclarator := CNVDeclarator;
3044 :     refCNVDeclaration := CNVDeclaration
3045 :     end
3046 :    
3047 :     fun makeAst' extDecls =
3048 :     let val _ = if !multi_file_mode then print "Warning: multi_file_mode on\n"
3049 :     else ()
3050 :     val _ = Sizeof.reset()
3051 :     (* this is the top-level call for this structure;
3052 :     * must reset sizeof memo table *)
3053 :     val astExtDecls =
3054 :     let fun process x =
3055 :     let val astExtDecl = cnvExternalDecl x
3056 :     val newtids = resetTids ()
3057 :     in (List.map (fn x => wrapDECL(Ast.ExternalDecl(Ast.TypeDecl{shadow=NONE, tid=x})))
3058 :     newtids)
3059 :     @ astExtDecl
3060 :     end
3061 :     in List.map process extDecls
3062 :     end
3063 :     val astExtDecls = List.concat astExtDecls
3064 :     val errorCount = Error.errorCount errorState
3065 :     val warningCount = Error.warningCount errorState
3066 :     in
3067 :     {ast=astExtDecls, tidtab=ttab, errorCount=errorCount, warningCount=warningCount,
3068 :     auxiliaryInfo = {aidtab=atab, implicits=implicits, env=getGlobalEnv()}}
3069 :     (* DBM: will we want to reuse errorState? *)
3070 :     end (* fun makeAst' *)
3071 :    
3072 :     in
3073 :     makeAst'
3074 :     end (* fun makeAst *)
3075 :    
3076 :     end (* local open Bindings *)
3077 :    
3078 :     end (* structure BuildAst *)

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