Ignore:
Timestamp:
Jan 19, 2011, 6:23:27 PM (9 years ago)
Author:
campbell
Message:

Port memory spaces changes to latest prototype compiler.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • Deliverables/D2.3/8051-memoryspaces-branch/cparser/Elab.ml

    r453 r460  
    273273      | Some a -> add_attributes [a] (elab_attributes loc al)
    274274
     275let elab_attribute_space = function
     276  | ("data", []) -> Some Data
     277  | ("idata", []) -> Some IData
     278  | ("pdata", []) -> Some PData
     279  | ("xdata", []) -> Some XData
     280  | ("code", []) -> Some Code
     281  | _ -> None
     282
     283let rec elab_attributes_space loc attrs =
     284  let rec aux = function
     285    | [] -> None
     286    | h::t -> (match elab_attribute_space h with
     287                | None -> aux t
     288                | Some v -> Some (v,t))
     289  in match aux attrs with
     290    | None -> Any
     291    | Some (space, rest) ->
     292       (match aux rest with
     293         | None -> ()
     294         | Some _ -> warning loc "Multiple memory spaces given");
     295       space
     296
    275297(* Auxiliary for typespec elaboration *)
    276298
     
    291313let typespec_order t1 t2 = compare (typespec_rank t1) (typespec_rank t2)
    292314
     315
    293316(* Elaboration of a type specifier.  Returns 4-tuple:
    294317     (storage class, "inline" flag, elaborated type, new env)
     
    305328  and inline = ref false
    306329  and attr = ref []
    307   and tyspecs = ref [] in
     330  and tyspecs = ref []
     331  and space = ref Any in
    308332
    309333  let do_specifier = function
     
    317341      attr := add_attributes [a] !attr
    318342  | SpecAttr a ->
    319       attr := add_attributes (elab_attributes loc [a]) !attr
     343      attr := add_attributes (elab_attributes loc [a]) !attr;
     344      (match elab_attribute_space a with
     345        | None -> ()
     346        | Some sp ->
     347           if !space <> Any then
     348             error loc "multiple memory space specifiers";
     349           space := sp)
    320350  | SpecStorage st ->
    321351      if !sto <> Storage_default then
     
    333363  List.iter do_specifier specifier;
    334364
    335   let simple ty = (!sto, !inline, add_attributes_type !attr ty, env) in
     365  let simple ty = (!space, !sto, !inline, add_attributes_type !attr ty, env) in
    336366
    337367  (* Now interpret the list of type specifiers.  Much of this code
     
    397427          elab_struct_or_union only Struct loc id optmembers env in
    398428        let attr' = add_attributes !attr (elab_attributes loc a) in
    399         (!sto, !inline, TStruct(id', attr'), env')
     429        (!space, !sto, !inline, TStruct(id', attr'), env')
    400430
    401431    | [Cabs.Tunion(id, optmembers, a)] ->
     
    403433          elab_struct_or_union only Union loc id optmembers env in
    404434        let attr' = add_attributes !attr (elab_attributes loc a) in
    405         (!sto, !inline, TUnion(id', attr'), env')
     435        (!space, !sto, !inline, TUnion(id', attr'), env')
    406436
    407437    | [Cabs.Tenum(id, optmembers, a)] ->
     
    409439          elab_enum loc id optmembers env in
    410440        let attr' = add_attributes !attr (elab_attributes loc a) in
    411         (!sto, !inline, TInt(enum_ikind, attr'), env')
     441        (!space, !sto, !inline, TInt(enum_ikind, attr'), env')
    412442
    413443    | [Cabs.TtypeofE _] ->
     
    422452(* Elaboration of a type declarator.  *)
    423453
    424 and elab_type_declarator loc env ty = function
     454and elab_type_declarator loc env space ty = function
    425455  | Cabs.JUSTBASE ->
    426       (ty, env)
     456      (space, ty, env)
    427457  | Cabs.PARENTYPE(attr1, d, attr2) ->
    428458      (* XXX ignoring the distinction between attrs after and before *)
    429459      let a = elab_attributes loc (attr1 @ attr2) in
    430       elab_type_declarator loc env (add_attributes_type a ty) d
     460      (* XXX ought to use space from attrs? *)
     461      elab_type_declarator loc env space (add_attributes_type a ty) d
    431462  | Cabs.ARRAY(d, attr, sz) ->
    432463      let a = elab_attributes loc attr in
     
    443474                error loc "array size is not a compile-time constant";
    444475                Some 1L in (* produces better error messages later *)
    445        elab_type_declarator loc env (TArray(ty, sz', a)) d
     476       elab_type_declarator loc env space (TArray(space, ty, sz', a)) d
    446477  | Cabs.PTR(attr, d) ->
    447478      let a = elab_attributes loc attr in
    448        elab_type_declarator loc env (TPtr(ty, a)) d
     479      let space' = elab_attributes_space loc attr in
     480       elab_type_declarator loc env space' (TPtr(space, ty, a)) d
    449481  | Cabs.PROTO(d, params, vararg) ->
    450482       begin match unroll env ty with
     
    454486       end;
    455487       let params' = elab_parameters env params in
    456        elab_type_declarator loc env (TFun(ty, params', vararg, [])) d
     488       elab_type_declarator loc env space (TFun(ty, params', vararg, [])) d
    457489
    458490(* Elaboration of parameters in a prototype *)
     
    479511  (* replace array and function types by pointer types *)
    480512  let ty1 = argument_conversion env1 ty in
    481   let (id', env2) = Env.enter_ident env1 id sto ty1 in
     513  let (id', env2) = Env.enter_ident env1 id sto ty1 Any (* stack *) in
    482514  ( (id', ty1) , env2 )
    483515
     
    485517
    486518and elab_name env spec (id, decl, attr, loc) =
    487   let (sto, inl, bty, env') = elab_specifier loc env spec in
    488   let (ty, env'') = elab_type_declarator loc env' bty decl in
     519  let (space, sto, inl, bty, env') = elab_specifier loc env spec in
     520  let (_, ty, env'') = elab_type_declarator loc env' space bty decl in
    489521  let a = elab_attributes loc attr in
    490522  (id, sto, inl, add_attributes_type a ty, env'')
     
    493525
    494526and elab_name_group env (spec, namelist) =
    495   let (sto, inl, bty, env') =
     527  let (space, sto, inl, bty, env') =
    496528    elab_specifier (loc_of_namelist namelist) env spec in
    497529  let elab_one_name env (id, decl, attr, loc) =
    498     let (ty, env1) =
    499       elab_type_declarator loc env bty decl in
     530    let (_, ty, env1) =
     531      elab_type_declarator loc env space bty decl in
    500532    let a = elab_attributes loc attr in
    501533    ((id, sto, add_attributes_type a ty), env1) in
     
    505537
    506538and elab_init_name_group env (spec, namelist) =
    507   let (sto, inl, bty, env') =
     539  let (space, sto, inl, bty, env') =
    508540    elab_specifier (loc_of_init_name_list namelist) env spec in
    509541  let elab_one_name env ((id, decl, attr, loc), init) =
    510     let (ty, env1) =
    511       elab_type_declarator loc env bty decl in
     542    let (space', ty, env1) =
     543      elab_type_declarator loc env space bty decl in
    512544    let a = elab_attributes loc attr in
    513     ((id, sto, add_attributes_type a ty, init), env1) in
     545    ((space', id, sto, add_attributes_type a ty, init), env1) in
    514546  mmap elab_one_name env' namelist
    515547
     
    561593  let rec check_incomplete = function
    562594  | [] -> ()
    563   | [ { fld_typ = TArray(ty_elt, None, _) } ] when kind = Struct -> ()
     595  | [ { fld_typ = TArray(_, ty_elt, None, _) } ] when kind = Struct -> ()
    564596        (* C99: ty[] allowed as last field of a struct *)
    565597  | fld :: rem ->
     
    666698
    667699let elab_type loc env spec decl =
    668   let (sto, inl, bty, env') = elab_specifier loc env spec in
    669   let (ty, env'') = elab_type_declarator loc env' bty decl in
     700  let (space, sto, inl, bty, env') = elab_specifier loc env spec in
     701  let (_, ty, env'') = elab_type_declarator loc env' space bty decl in
    670702  if sto <> Storage_default || inl then
    671703    error loc "'extern', 'static', 'register' and 'inline' are meaningless in cast";
     
    673705
    674706
     707let join_spaces s1 s2 =
     708if s1 = s2 then s1 else Any
     709
     710
    675711
    676712(* Elaboration of expressions *)
     
    691727  | VARIABLE s ->
    692728      begin match wrap Env.lookup_ident loc env s with
    693       | (id, II_ident(sto, ty)) ->
    694           { edesc = EVar id; etyp = ty }
     729      | (id, II_ident(sto, ty, spc)) ->
     730          { edesc = EVar id; etyp = ty; espace=spc }
    695731      | (id, II_enum v) ->
    696           { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) }
     732          { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []); espace = Code }
    697733      end
    698734
    699735  | CONSTANT cst ->
    700736      let cst' = elab_constant loc cst in
    701       { edesc = EConst cst'; etyp = type_of_constant cst' }
     737      { edesc = EConst cst'; etyp = type_of_constant cst'; espace = Code }
    702738
    703739  | PAREN e ->
     
    708744  | INDEX(a1, a2) ->            (* e1[e2] *)
    709745      let b1 = elab a1 in let b2 = elab a2 in
    710       let tres =
     746      let space, tres =
    711747        match (unroll env b1.etyp, unroll env b2.etyp) with
    712         | (TPtr(t, _) | TArray(t, _, _)), TInt _ -> t
    713         | TInt _, (TPtr(t, _) | TArray(t, _, _)) -> t
     748        | (TPtr(space, t, _) | TArray(space, t, _, _)), TInt _ -> space, t
     749        | TInt _, (TPtr(space, t, _) | TArray(space, t, _, _)) -> space, t
    714750        | t1, t2 -> error "incorrect types for array subscripting" in
    715       { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres }
     751      { edesc = EBinop(Oindex, b1, b2, TPtr(space, tres, [])); etyp = tres; espace = space }
    716752
    717753  | MEMBEROF(a1, fieldname) ->
     
    727763      (* A field of a const/volatile struct or union is itself const/volatile *)
    728764      { edesc = EUnop(Odot fieldname, b1);
    729         etyp = add_attributes_type attrs fld.fld_typ }
     765        etyp = add_attributes_type attrs fld.fld_typ;
     766        espace = b1.espace }
    730767
    731768  | MEMBEROFPTR(a1, fieldname) ->
    732769      let b1 = elab a1 in
    733       let (fld, attrs) =
     770      let (space, fld, attrs) =
    734771        match unroll env b1.etyp with
    735         | TPtr(t, _) ->
     772        | TPtr(space, t, _) ->
    736773            begin match unroll env t with
    737774            | TStruct(id, attrs) ->
    738                 (wrap Env.find_struct_member loc env (id, fieldname), attrs)
     775                (space, wrap Env.find_struct_member loc env (id, fieldname), attrs)
    739776            | TUnion(id, attrs) ->
    740                 (wrap Env.find_union_member loc env (id, fieldname), attrs)
     777                (space, wrap Env.find_union_member loc env (id, fieldname), attrs)
    741778            | _ ->
    742779                error "left-hand side of '->' is not a pointer to a struct or union"
     
    745782            error "left-hand side of '->' is not a pointer " in
    746783      { edesc = EUnop(Oarrow fieldname, b1);
    747         etyp = add_attributes_type attrs fld.fld_typ }
     784        etyp = add_attributes_type attrs fld.fld_typ;
     785        espace = space }
    748786
    749787(* Hack to treat vararg.h functions the GCC way.  Helps with testing.
     
    758796      let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in
    759797      { edesc = ECall(b1, [b2; {edesc = EUnop(Oaddrof, b3);
    760                                 etyp = TPtr(b3.etyp, [])}]);
    761         etyp = TVoid [] }
     798                                etyp = TPtr(b3.espace, b3.etyp, []);
     799                                espace = Any }]);
     800        etyp = TVoid [];
     801        espace = Any (* XXX ? *) }
    762802  | CALL((VARIABLE "__builtin_va_arg" as a1),
    763803         [a2; (TYPE_SIZEOF _) as a3]) ->
    764804      let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in
    765805      let ty = match b3.edesc with ESizeof ty -> ty | _ -> assert false in
    766       { edesc = ECall(b1, [b2; b3]); etyp = ty }
     806      { edesc = ECall(b1, [b2; b3]); etyp = ty; espace = Any (* XXX ? *) }
    767807
    768808  | CALL(a1, al) ->
     
    775815            (* Emit an extern declaration for it *)
    776816            let id = Env.fresh_ident n in
    777             emit_elab (elab_loc loc) (Gdecl(Storage_extern, id, ty, None));
    778             { edesc = EVar id; etyp = ty }
     817            emit_elab (elab_loc loc) (Gdecl(Code, (Storage_extern, id, ty, None)));
     818            { edesc = EVar id; etyp = ty; espace = Any }
    779819        | _ -> elab a1 in
    780820      let bl = List.map elab al in
     
    783823        match unroll env b1.etyp with
    784824        | TFun(res, args, vararg, a) -> (res, args, vararg)
    785         | TPtr(ty, a) ->
     825        | TPtr(_, ty, a) ->
    786826            begin match unroll env ty with
    787827            | TFun(res, args, vararg, a) -> (res, args, vararg)
     
    795835        | None -> bl
    796836        | Some proto -> elab_arguments 1 bl proto vararg in
    797       { edesc = ECall(b1, bl'); etyp = res }
     837      { edesc = ECall(b1, bl'); etyp = res; espace = Any (* Stack *) }
    798838
    799839  | UNARY(POSINCR, a1) ->
     
    809849      if not (valid_cast env b1.etyp ty) then
    810850        err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty;
    811       { edesc = ECast(ty, b1); etyp = ty }
     851      { edesc = ECast(ty, b1); etyp = ty; espace = b1.espace }
    812852
    813853  | CAST ((spec, dcl), _) ->
     
    816856  | EXPR_SIZEOF(CONSTANT(CONST_STRING s)) ->
    817857      let cst = CInt(Int64.of_int (String.length s), size_t_ikind, "") in
    818       { edesc = EConst cst; etyp = type_of_constant cst }
     858      { edesc = EConst cst; etyp = type_of_constant cst; espace = Code }
    819859
    820860  | EXPR_SIZEOF a1 ->
     
    822862      if sizeof env b1.etyp = None then
    823863        err "incomplete type %a" Cprint.typ b1.etyp;
    824       { edesc = ESizeof b1.etyp; etyp = TInt(size_t_ikind, []) }
     864      { edesc = ESizeof b1.etyp; etyp = TInt(size_t_ikind, []); espace = Code }
    825865
    826866  | TYPE_SIZEOF (spec, dcl) ->
     
    828868      if sizeof env ty = None then
    829869        err "incomplete type %a" Cprint.typ ty;
    830       { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []) }
     870      { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []); espace = Code }
    831871
    832872  | UNARY(PLUS, a1) ->
     
    834874      if not (is_arith_type env b1.etyp) then
    835875        error "argument of unary '+' is not an arithmetic type";
    836       { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp }
     876      { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp; espace = Any }
    837877
    838878  | UNARY(MINUS, a1) ->
     
    840880      if not (is_arith_type env b1.etyp) then
    841881        error "argument of unary '-' is not an arithmetic type";
    842       { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp }
     882      { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp; espace = Any }
    843883
    844884  | UNARY(BNOT, a1) ->
     
    846886      if not (is_integer_type env b1.etyp) then
    847887        error "argument of '~' is not an integer type";
    848       { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp }
     888      { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp; espace = Any }
    849889
    850890  | UNARY(NOT, a1) ->
     
    852892      if not (is_scalar_type env b1.etyp) then
    853893        error "argument of '!' is not a scalar type";
    854       { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []) }
     894      { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []); espace = Any }
    855895
    856896  | UNARY(ADDROF, a1) ->
     
    861901        if not (is_lvalue env b1) then err "argument of '&' is not a l-value"
    862902      end;
    863       { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.etyp, []) }
     903      { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.espace, b1.etyp, []); espace = Any }
    864904
    865905  | UNARY(MEMOF, a1) ->
     
    868908      (* '*' applied to a function type has no effect *)
    869909      | TFun _ -> b1
    870       | TPtr(ty, _) | TArray(ty, _, _) ->
    871           { edesc = EUnop(Oderef, b1); etyp = ty }
     910      | TPtr(space, ty, _) | TArray(space, ty, _, _) ->
     911          { edesc = EUnop(Oderef, b1); etyp = ty; espace = space }
    872912      | _ ->
    873913          error "argument of unary '*' is not a pointer"
     
    897937          binary_conversion env b1.etyp b2.etyp
    898938        else begin
    899           let (ty, attr) =
     939          let (space, ty, attr) =
    900940            match unroll env b1.etyp, unroll env b2.etyp with
    901             | (TPtr(ty, a) | TArray(ty, _, a)), TInt _ -> (ty, a)
    902             | TInt _, (TPtr(ty, a) | TArray(ty, _, a)) -> (ty, a)
     941            | (TPtr(space, ty, a) | TArray(space, ty, _, a)), TInt _ -> (space, ty, a)
     942            | TInt _, (TPtr(space, ty, a) | TArray(space, ty, _, a)) -> (space, ty, a)
    903943            | _, _ -> error "type error in binary '+'" in
    904944          if not (pointer_arithmetic_ok env ty) then
    905945            err "illegal pointer arithmetic in binary '+'";
    906           TPtr(ty, attr)
     946          TPtr(space, ty, attr)
    907947        end in
    908       { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres }
     948      { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres; espace = Any }
    909949
    910950  | BINARY(SUB, a1, a2) ->
     
    917957        end else begin
    918958          match unroll env b1.etyp, unroll env b2.etyp with
    919           | (TPtr(ty, a) | TArray(ty, _, a)), TInt _ ->
     959          | (TPtr(space, ty, a) | TArray(space, ty, _, a)), TInt _ ->
    920960              if not (pointer_arithmetic_ok env ty) then
    921961                err "illegal pointer arithmetic in binary '-'";
    922               (TPtr(ty, a), TPtr(ty, a))
    923           | TInt _, (TPtr(ty, a) | TArray(ty, _, a)) ->
     962              (TPtr(space, ty, a), TPtr(space, ty, a))
     963          | TInt _, (TPtr(space, ty, a) | TArray(space, ty, _, a)) ->
    924964              if not (pointer_arithmetic_ok env ty) then
    925965                err "illegal pointer arithmetic in binary '-'";
    926               (TPtr(ty, a), TPtr(ty, a))
    927           | (TPtr(ty1, a1) | TArray(ty1, _, a1)),
    928             (TPtr(ty2, a2) | TArray(ty2, _, a2)) ->
    929               if not (compatible_types ~noattrs:true env ty1 ty2) then
     966              (TPtr(space, ty, a), TPtr(space, ty, a))
     967          | (TPtr(space1, ty1, a1) | TArray(space1, ty1, _, a1)),
     968            (TPtr(space2, ty2, a2) | TArray(space2, ty2, _, a2)) ->
     969(* TODO: automatic cast on space mismatch? *)
     970              if not (compatible_types ~noattrs:true env ty1 ty2) || space1 != space2 then
    930971                err "mismatch between pointer types in binary '-'";
    931972              if not (pointer_arithmetic_ok env ty1) then
    932973                err "illegal pointer arithmetic in binary '-'";
    933               (TPtr(ty1, []), TInt(ptrdiff_t_ikind, []))
     974              (TPtr(space1, ty1, []), TInt(ptrdiff_t_ikind, []))
    934975          | _, _ -> error "type error in binary '-'"
    935976        end in
    936       { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres }
     977      { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres; espace = Any }
    937978
    938979  | BINARY(SHL, a1, a2) ->
     
    9741015      let b2 = elab a2 in
    9751016      let b3 = elab a3 in
     1017      let space = join_spaces b2.espace b3.espace in
    9761018      if not (is_scalar_type env b1.etyp) then
    9771019        err ("the first argument of '? :' is not a scalar type");
     
    9791021      | (TInt _ | TFloat _), (TInt _ | TFloat _) ->
    9801022          { edesc = EConditional(b1, b2, b3);
    981             etyp = binary_conversion env b2.etyp b3.etyp }
    982       | TPtr(ty1, a1), TPtr(ty2, a2) ->
     1023            etyp = binary_conversion env b2.etyp b3.etyp;
     1024            espace = space }
     1025      (* TODO: maybe we should automatically cast to a generic pointer when the spaces don't match? *)
     1026      | TPtr(sp1, ty1, a1), TPtr(sp2, ty2, a2) ->
    9831027          let tyres =
    984             if is_void_type env ty1 || is_void_type env ty2 then
    985               TPtr(TVoid [], add_attributes a1 a2)
     1028            if (is_void_type env ty1 || is_void_type env ty2) && sp1 = sp2 then
     1029              TPtr(sp1, TVoid [], add_attributes a1 a2)
    9861030            else
    9871031              match combine_types ~noattrs:true env
    988                                   (TPtr(ty1, a1)) (TPtr(ty2, a2)) with
     1032                                  (TPtr(sp1, ty1, a1)) (TPtr(sp2, ty2, a2)) with
    9891033              | None ->
    9901034                  error "the second and third arguments of '? :' \
     
    9921036              | Some ty -> ty
    9931037            in
    994           { edesc = EConditional(b1, b2, b3); etyp = tyres }
    995       | TPtr(ty1, a1), TInt _ when is_literal_0 b3 ->
    996           { edesc = EConditional(b1, b2, nullconst); etyp = TPtr(ty1, a1) }
    997       | TInt _, TPtr(ty2, a2) when is_literal_0 b2 ->
    998           { edesc = EConditional(b1, nullconst, b3); etyp = TPtr(ty2, a2) }
     1038          { edesc = EConditional(b1, b2, b3); etyp = tyres; espace = space }
     1039      | TPtr(sp1, ty1, a1), TInt _ when is_literal_0 b3 ->
     1040          { edesc = EConditional(b1, b2, nullconst); etyp = TPtr(sp1, ty1, a1); espace = space }
     1041      | TInt _, TPtr(sp2, ty2, a2) when is_literal_0 b2 ->
     1042          { edesc = EConditional(b1, nullconst, b3); etyp = TPtr(sp2, ty2, a2); espace = space }
    9991043      | ty1, ty2 ->
    10001044          match combine_types env ty1 ty2 with
     
    10021046              error ("the second and third arguments of '? :' have incompatible types")
    10031047          | Some tyres ->
    1004               { edesc = EConditional(b1, b2, b3); etyp = tyres }
     1048              { edesc = EConditional(b1, b2, b3); etyp = tyres; espace = space }
    10051049      end
    10061050
     
    10221066                  Cprint.typ b2.etyp Cprint.typ b1.etyp;
    10231067      end;
    1024       { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp }
     1068      { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp; espace = b1.espace }
    10251069
    10261070  | BINARY((ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
     
    10541098                      Cprint.typ ty Cprint.typ b1.etyp;
    10551099          end;
    1056           { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp }
     1100          { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp; espace = b1.espace }
    10571101      | _ -> assert false
    10581102      end
     
    10671111      | a :: l ->
    10681112          let b = elab a in
    1069           elab_comma { edesc = EBinop(Ocomma, accu, b, b.etyp); etyp = b.etyp } l
     1113          elab_comma { edesc = EBinop(Ocomma, accu, b, b.etyp); etyp = b.etyp; espace = b.espace } l
    10701114      in elab_comma (elab a1) al
    10711115
     
    11031147      if not (is_scalar_type env b1.etyp) then
    11041148        err "the argument of %s must be an arithmetic or pointer type" msg;
    1105       { edesc = EUnop(op, b1); etyp = b1.etyp }
     1149      { edesc = EUnop(op, b1); etyp = b1.etyp; espace = b1.espace }
    11061150
    11071151(* Elaboration of binary operators over integers *)
     
    11141158        error "the second argument of '%s' is not an integer type" msg;
    11151159      let tyres = binary_conversion env b1.etyp b2.etyp in
    1116       { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
     1160      { edesc = EBinop(op, b1, b2, tyres); etyp = tyres; espace = Any }
    11171161
    11181162(* Elaboration of binary operators over arithmetic types *)
     
    11251169        error "the second argument of '%s' is not an arithmetic type" msg;
    11261170      let tyres = binary_conversion env b1.etyp b2.etyp in
    1127       { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
     1171      { edesc = EBinop(op, b1, b2, tyres); etyp = tyres; espace = Any }
    11281172
    11291173(* Elaboration of shift operators *)
     
    11361180        error "the second argument of '%s' is not an integer type" msg;
    11371181      let tyres = unary_conversion env b1.etyp in
    1138       { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
     1182      { edesc = EBinop(op, b1, b2, tyres); etyp = tyres; espace = Any }
    11391183
    11401184(* Elaboration of comparisons *)
     
    11461190        | (TInt _ | TFloat _), (TInt _ | TFloat _) ->
    11471191            EBinop(op, b1, b2, binary_conversion env b1.etyp b2.etyp)
    1148         | TInt _, TPtr(ty, _) when is_literal_0 b1 ->
    1149             EBinop(op, nullconst, b2, TPtr(ty, []))
    1150         | TPtr(ty, _), TInt _ when is_literal_0 b2 ->
    1151             EBinop(op, b1, nullconst, TPtr(ty, []))
    1152         | TPtr(ty1, _), TPtr(ty2, _)
     1192        | TInt _, TPtr(sp, ty, _) when is_literal_0 b1 ->
     1193            EBinop(op, nullconst, b2, TPtr(sp, ty, []))
     1194        | TPtr(sp, ty, _), TInt _ when is_literal_0 b2 ->
     1195            EBinop(op, b1, nullconst, TPtr(sp, ty, []))
     1196        | TPtr(sp1, ty1, _), TPtr(sp2, ty2, _)
    11531197          when is_void_type env ty1 ->
    1154             EBinop(op, b1, b2, TPtr(ty2, []))
    1155         | TPtr(ty1, _), TPtr(ty2, _)
     1198            EBinop(op, b1, b2, TPtr(sp2, ty2, []))  (* XXX sp1? *)
     1199        | TPtr(sp1, ty1, _), TPtr(sp2, ty2, _)
    11561200          when is_void_type env ty2 ->
    1157             EBinop(op, b1, b2, TPtr(ty1, []))
    1158         | TPtr(ty1, _), TPtr(ty2, _) ->
     1201            EBinop(op, b1, b2, TPtr(sp1, ty1, []))  (* XXX sp2? *)
     1202        | TPtr(sp1, ty1, _), TPtr(sp2, ty2, _) ->
    11591203            if not (compatible_types ~noattrs:true env ty1 ty2) then
    11601204              warning "comparison between incompatible pointer types";
    1161             EBinop(op, b1, b2, TPtr(ty1, []))
    1162         | TPtr _, TInt _
    1163         | TInt _, TPtr _ ->
     1205            EBinop(op, b1, b2, TPtr(sp1, ty1, []))  (* XXX sp1? *)
     1206        | TPtr (sp,_,_), TInt _
     1207        | TInt _, TPtr (sp,_,_) ->
    11641208            warning "comparison between integer and pointer";
    1165             EBinop(op, b1, b2, TPtr(TVoid [], []))
     1209            EBinop(op, b1, b2, TPtr(sp,TVoid [], []))
    11661210        | ty1, ty2 ->
    11671211            error "illegal comparison between types@ %a@ and %a"
    11681212                  Cprint.typ b1.etyp Cprint.typ b2.etyp in
    1169       { edesc = resdesc; etyp = TInt(IInt, []) }
     1213      { edesc = resdesc; etyp = TInt(IInt, []); espace = Any }
    11701214
    11711215(* Elaboration of && and || *)
     
    11771221      if not (is_scalar_type env b2.etyp) then
    11781222        err "the second argument of '%s' is not a scalar type" msg;
    1179       { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []) }
     1223      { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []); espace = Any }
    11801224
    11811225(* Type-checking of function arguments *)
     
    12761320let rec elab_init loc env ty ile =
    12771321  match unroll env ty with
    1278   | TArray(ty_elt, opt_sz, _) ->
     1322  | TArray(space, ty_elt, opt_sz, _) ->
    12791323      let rec elab_init_array n accu rem =
    12801324        match opt_sz, rem with
     
    13951439let fixup_typ env ty init =
    13961440  match unroll env ty, init with
    1397   | TArray(ty_elt, None, attr), Init_array il ->
    1398       TArray(ty_elt, Some(Int64.of_int(List.length il)), attr)
     1441  | TArray(space, ty_elt, None, attr), Init_array il ->
     1442      TArray(space, ty_elt, Some(Int64.of_int(List.length il)), attr)
    13991443  | _ -> ty
    14001444
     
    14221466  env'
    14231467
    1424 let enter_or_refine_ident local loc env s sto ty =
     1468let enter_or_refine_ident local loc env s sto ty space =
    14251469  match redef Env.lookup_ident env s with
    1426   | Some(id, II_ident(old_sto, old_ty)) ->
     1470  | Some(id, II_ident(old_sto, old_ty, old_space)) ->
    14271471      let new_ty =
    14281472        if local then begin
     
    14431487          sto
    14441488        end in
    1445       (id, Env.add_ident env id new_sto new_ty)
     1489      let new_space = join_spaces old_space space (* XXX: incompatible? *) in
     1490      (id, Env.add_ident env id new_sto new_ty new_space)
    14461491  | Some(id, II_enum v) ->
    14471492      error loc "illegal redefinition of enumerator '%s'" s;
    1448       (id, Env.add_ident env id sto ty)
     1493      (id, Env.add_ident env id sto ty space)
    14491494  | _ ->
    1450       Env.enter_ident env s sto ty
     1495      Env.enter_ident env s sto ty space
    14511496
    14521497let rec enter_decdefs local loc env = function
    14531498  | [] ->
    14541499      ([], env)
    1455   | (s, sto, ty, init) :: rem ->
     1500  | (space, s, sto, ty, init) :: rem ->
    14561501      (* Sanity checks on storage class *)
    14571502      begin match sto with
     
    14681513      (* enter ident in environment with declared type, because
    14691514         initializer can refer to the ident *)
    1470       let (id, env1) = enter_or_refine_ident local loc env s sto' ty in
     1515      let (id, env1) = enter_or_refine_ident local loc env s sto' ty space in
    14711516      (* process the initializer *)
    14721517      let (ty', init') = elab_initializer loc env1 ty init in
    14731518      (* update environment with refined type *)
    1474       let env2 = Env.add_ident env1 id sto' ty' in
     1519      let env2 = Env.add_ident env1 id sto' ty' space in
    14751520      (* check for incomplete type *)
    14761521      if sto' <> Storage_extern && incomplete_type env ty' then
     
    14821527      end else begin
    14831528        (* Global definition *)
    1484         emit_elab (elab_loc loc) (Gdecl(sto, id, ty', init'));
     1529        emit_elab (elab_loc loc) (Gdecl(space, (sto, id, ty', init')));
    14851530        enter_decdefs local loc env2 rem
    14861531      end
     
    15021547    | _ -> fatal_error loc1 "wrong type for function definition" in
    15031548  (* Enter function in the environment, for recursive references *)
    1504   let (fun_id, env1) = enter_or_refine_ident false loc1 env s sto ty in
     1549  let (fun_id, env1) = enter_or_refine_ident false loc1 env s sto ty Code in
    15051550  (* Enter parameters in the environment *)
    15061551  let env2 =
    1507     List.fold_left (fun e (id, ty) -> Env.add_ident e id Storage_default ty)
     1552    List.fold_left (fun e (id, ty) -> Env.add_ident e id Storage_default ty Any)
    15081553                   (Env.new_scope env1) params in
    15091554  (* Elaborate function body *)
     
    15441589  (* "struct s { ...};" or "union u;" *)
    15451590  | ONLYTYPEDEF(spec, loc) ->
    1546       let (sto, inl, ty, env') = elab_specifier ~only:true loc env spec in
     1591      let (space, sto, inl, ty, env') = elab_specifier ~only:true loc env spec in
    15471592      if sto <> Storage_default || inl then
    15481593        error loc "Non-default storage or 'inline' on 'struct' or 'union' declaration";
Note: See TracChangeset for help on using the changeset viewer.