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/branches/primop-branch-2/ckit/src/ast/build-ast.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/ckit/src/ast/build-ast.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1935 - (view) (download)

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

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