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

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