 Timestamp:
 Jan 19, 2011, 6:23:27 PM (9 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

Deliverables/D2.3/8051memoryspacesbranch/cparser/Elab.ml
r453 r460 273 273  Some a > add_attributes [a] (elab_attributes loc al) 274 274 275 let 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 283 let 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 275 297 (* Auxiliary for typespec elaboration *) 276 298 … … 291 313 let typespec_order t1 t2 = compare (typespec_rank t1) (typespec_rank t2) 292 314 315 293 316 (* Elaboration of a type specifier. Returns 4tuple: 294 317 (storage class, "inline" flag, elaborated type, new env) … … 305 328 and inline = ref false 306 329 and attr = ref [] 307 and tyspecs = ref [] in 330 and tyspecs = ref [] 331 and space = ref Any in 308 332 309 333 let do_specifier = function … … 317 341 attr := add_attributes [a] !attr 318 342  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) 320 350  SpecStorage st > 321 351 if !sto <> Storage_default then … … 333 363 List.iter do_specifier specifier; 334 364 335 let simple ty = (!s to, !inline, add_attributes_type !attr ty, env) in365 let simple ty = (!space, !sto, !inline, add_attributes_type !attr ty, env) in 336 366 337 367 (* Now interpret the list of type specifiers. Much of this code … … 397 427 elab_struct_or_union only Struct loc id optmembers env in 398 428 let attr' = add_attributes !attr (elab_attributes loc a) in 399 (!s to, !inline, TStruct(id', attr'), env')429 (!space, !sto, !inline, TStruct(id', attr'), env') 400 430 401 431  [Cabs.Tunion(id, optmembers, a)] > … … 403 433 elab_struct_or_union only Union loc id optmembers env in 404 434 let attr' = add_attributes !attr (elab_attributes loc a) in 405 (!s to, !inline, TUnion(id', attr'), env')435 (!space, !sto, !inline, TUnion(id', attr'), env') 406 436 407 437  [Cabs.Tenum(id, optmembers, a)] > … … 409 439 elab_enum loc id optmembers env in 410 440 let attr' = add_attributes !attr (elab_attributes loc a) in 411 (!s to, !inline, TInt(enum_ikind, attr'), env')441 (!space, !sto, !inline, TInt(enum_ikind, attr'), env') 412 442 413 443  [Cabs.TtypeofE _] > … … 422 452 (* Elaboration of a type declarator. *) 423 453 424 and elab_type_declarator loc env ty = function454 and elab_type_declarator loc env space ty = function 425 455  Cabs.JUSTBASE > 426 ( ty, env)456 (space, ty, env) 427 457  Cabs.PARENTYPE(attr1, d, attr2) > 428 458 (* XXX ignoring the distinction between attrs after and before *) 429 459 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 431 462  Cabs.ARRAY(d, attr, sz) > 432 463 let a = elab_attributes loc attr in … … 443 474 error loc "array size is not a compiletime constant"; 444 475 Some 1L in (* produces better error messages later *) 445 elab_type_declarator loc env (TArray(ty, sz', a)) d476 elab_type_declarator loc env space (TArray(space, ty, sz', a)) d 446 477  Cabs.PTR(attr, d) > 447 478 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 449 481  Cabs.PROTO(d, params, vararg) > 450 482 begin match unroll env ty with … … 454 486 end; 455 487 let params' = elab_parameters env params in 456 elab_type_declarator loc env (TFun(ty, params', vararg, [])) d488 elab_type_declarator loc env space (TFun(ty, params', vararg, [])) d 457 489 458 490 (* Elaboration of parameters in a prototype *) … … 479 511 (* replace array and function types by pointer types *) 480 512 let ty1 = argument_conversion env1 ty in 481 let (id', env2) = Env.enter_ident env1 id sto ty1 in513 let (id', env2) = Env.enter_ident env1 id sto ty1 Any (* stack *) in 482 514 ( (id', ty1) , env2 ) 483 515 … … 485 517 486 518 and elab_name env spec (id, decl, attr, loc) = 487 let (s to, inl, bty, env') = elab_specifier loc env spec in488 let ( ty, env'') = elab_type_declarator loc env'bty decl in519 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 489 521 let a = elab_attributes loc attr in 490 522 (id, sto, inl, add_attributes_type a ty, env'') … … 493 525 494 526 and elab_name_group env (spec, namelist) = 495 let (s to, inl, bty, env') =527 let (space, sto, inl, bty, env') = 496 528 elab_specifier (loc_of_namelist namelist) env spec in 497 529 let elab_one_name env (id, decl, attr, loc) = 498 let ( ty, env1) =499 elab_type_declarator loc env bty decl in530 let (_, ty, env1) = 531 elab_type_declarator loc env space bty decl in 500 532 let a = elab_attributes loc attr in 501 533 ((id, sto, add_attributes_type a ty), env1) in … … 505 537 506 538 and elab_init_name_group env (spec, namelist) = 507 let (s to, inl, bty, env') =539 let (space, sto, inl, bty, env') = 508 540 elab_specifier (loc_of_init_name_list namelist) env spec in 509 541 let elab_one_name env ((id, decl, attr, loc), init) = 510 let ( ty, env1) =511 elab_type_declarator loc env bty decl in542 let (space', ty, env1) = 543 elab_type_declarator loc env space bty decl in 512 544 let a = elab_attributes loc attr in 513 (( id, sto, add_attributes_type a ty, init), env1) in545 ((space', id, sto, add_attributes_type a ty, init), env1) in 514 546 mmap elab_one_name env' namelist 515 547 … … 561 593 let rec check_incomplete = function 562 594  [] > () 563  [ { fld_typ = TArray( ty_elt, None, _) } ] when kind = Struct > ()595  [ { fld_typ = TArray(_, ty_elt, None, _) } ] when kind = Struct > () 564 596 (* C99: ty[] allowed as last field of a struct *) 565 597  fld :: rem > … … 666 698 667 699 let elab_type loc env spec decl = 668 let (s to, inl, bty, env') = elab_specifier loc env spec in669 let ( ty, env'') = elab_type_declarator loc env'bty decl in700 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 670 702 if sto <> Storage_default  inl then 671 703 error loc "'extern', 'static', 'register' and 'inline' are meaningless in cast"; … … 673 705 674 706 707 let join_spaces s1 s2 = 708 if s1 = s2 then s1 else Any 709 710 675 711 676 712 (* Elaboration of expressions *) … … 691 727  VARIABLE s > 692 728 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 } 695 731  (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 } 697 733 end 698 734 699 735  CONSTANT cst > 700 736 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 } 702 738 703 739  PAREN e > … … 708 744  INDEX(a1, a2) > (* e1[e2] *) 709 745 let b1 = elab a1 in let b2 = elab a2 in 710 let tres =746 let space, tres = 711 747 match (unroll env b1.etyp, unroll env b2.etyp) with 712  (TPtr( t, _)  TArray(t, _, _)), TInt _ >t713  TInt _, (TPtr( t, _)  TArray(t, _, _)) >t748  (TPtr(space, t, _)  TArray(space, t, _, _)), TInt _ > space, t 749  TInt _, (TPtr(space, t, _)  TArray(space, t, _, _)) > space, t 714 750  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 } 716 752 717 753  MEMBEROF(a1, fieldname) > … … 727 763 (* A field of a const/volatile struct or union is itself const/volatile *) 728 764 { 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 } 730 767 731 768  MEMBEROFPTR(a1, fieldname) > 732 769 let b1 = elab a1 in 733 let ( fld, attrs) =770 let (space, fld, attrs) = 734 771 match unroll env b1.etyp with 735  TPtr( t, _) >772  TPtr(space, t, _) > 736 773 begin match unroll env t with 737 774  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) 739 776  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) 741 778  _ > 742 779 error "lefthand side of '>' is not a pointer to a struct or union" … … 745 782 error "lefthand side of '>' is not a pointer " in 746 783 { 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 } 748 786 749 787 (* Hack to treat vararg.h functions the GCC way. Helps with testing. … … 758 796 let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in 759 797 { 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 ? *) } 762 802  CALL((VARIABLE "__builtin_va_arg" as a1), 763 803 [a2; (TYPE_SIZEOF _) as a3]) > 764 804 let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in 765 805 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 ? *) } 767 807 768 808  CALL(a1, al) > … … 775 815 (* Emit an extern declaration for it *) 776 816 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 } 779 819  _ > elab a1 in 780 820 let bl = List.map elab al in … … 783 823 match unroll env b1.etyp with 784 824  TFun(res, args, vararg, a) > (res, args, vararg) 785  TPtr( ty, a) >825  TPtr(_, ty, a) > 786 826 begin match unroll env ty with 787 827  TFun(res, args, vararg, a) > (res, args, vararg) … … 795 835  None > bl 796 836  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 *) } 798 838 799 839  UNARY(POSINCR, a1) > … … 809 849 if not (valid_cast env b1.etyp ty) then 810 850 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 } 812 852 813 853  CAST ((spec, dcl), _) > … … 816 856  EXPR_SIZEOF(CONSTANT(CONST_STRING s)) > 817 857 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 } 819 859 820 860  EXPR_SIZEOF a1 > … … 822 862 if sizeof env b1.etyp = None then 823 863 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 } 825 865 826 866  TYPE_SIZEOF (spec, dcl) > … … 828 868 if sizeof env ty = None then 829 869 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 } 831 871 832 872  UNARY(PLUS, a1) > … … 834 874 if not (is_arith_type env b1.etyp) then 835 875 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 } 837 877 838 878  UNARY(MINUS, a1) > … … 840 880 if not (is_arith_type env b1.etyp) then 841 881 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 } 843 883 844 884  UNARY(BNOT, a1) > … … 846 886 if not (is_integer_type env b1.etyp) then 847 887 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 } 849 889 850 890  UNARY(NOT, a1) > … … 852 892 if not (is_scalar_type env b1.etyp) then 853 893 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 } 855 895 856 896  UNARY(ADDROF, a1) > … … 861 901 if not (is_lvalue env b1) then err "argument of '&' is not a lvalue" 862 902 end; 863 { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.e typ, [])}903 { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.espace, b1.etyp, []); espace = Any } 864 904 865 905  UNARY(MEMOF, a1) > … … 868 908 (* '*' applied to a function type has no effect *) 869 909  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 } 872 912  _ > 873 913 error "argument of unary '*' is not a pointer" … … 897 937 binary_conversion env b1.etyp b2.etyp 898 938 else begin 899 let ( ty, attr) =939 let (space, ty, attr) = 900 940 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) 903 943  _, _ > error "type error in binary '+'" in 904 944 if not (pointer_arithmetic_ok env ty) then 905 945 err "illegal pointer arithmetic in binary '+'"; 906 TPtr( ty, attr)946 TPtr(space, ty, attr) 907 947 end in 908 { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres }948 { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres; espace = Any } 909 949 910 950  BINARY(SUB, a1, a2) > … … 917 957 end else begin 918 958 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 _ > 920 960 if not (pointer_arithmetic_ok env ty) then 921 961 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)) > 924 964 if not (pointer_arithmetic_ok env ty) then 925 965 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 930 971 err "mismatch between pointer types in binary ''"; 931 972 if not (pointer_arithmetic_ok env ty1) then 932 973 err "illegal pointer arithmetic in binary ''"; 933 (TPtr( ty1, []), TInt(ptrdiff_t_ikind, []))974 (TPtr(space1, ty1, []), TInt(ptrdiff_t_ikind, [])) 934 975  _, _ > error "type error in binary ''" 935 976 end in 936 { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres }977 { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres; espace = Any } 937 978 938 979  BINARY(SHL, a1, a2) > … … 974 1015 let b2 = elab a2 in 975 1016 let b3 = elab a3 in 1017 let space = join_spaces b2.espace b3.espace in 976 1018 if not (is_scalar_type env b1.etyp) then 977 1019 err ("the first argument of '? :' is not a scalar type"); … … 979 1021  (TInt _  TFloat _), (TInt _  TFloat _) > 980 1022 { 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) > 983 1027 let tyres = 984 if is_void_type env ty1  is_void_type env ty2 then985 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) 986 1030 else 987 1031 match combine_types ~noattrs:true env 988 (TPtr( ty1, a1)) (TPtr(ty2, a2)) with1032 (TPtr(sp1, ty1, a1)) (TPtr(sp2, ty2, a2)) with 989 1033  None > 990 1034 error "the second and third arguments of '? :' \ … … 992 1036  Some ty > ty 993 1037 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 } 999 1043  ty1, ty2 > 1000 1044 match combine_types env ty1 ty2 with … … 1002 1046 error ("the second and third arguments of '? :' have incompatible types") 1003 1047  Some tyres > 1004 { edesc = EConditional(b1, b2, b3); etyp = tyres }1048 { edesc = EConditional(b1, b2, b3); etyp = tyres; espace = space } 1005 1049 end 1006 1050 … … 1022 1066 Cprint.typ b2.etyp Cprint.typ b1.etyp; 1023 1067 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 } 1025 1069 1026 1070  BINARY((ADD_ASSIGN  SUB_ASSIGN  MUL_ASSIGN  DIV_ASSIGN  MOD_ASSIGN … … 1054 1098 Cprint.typ ty Cprint.typ b1.etyp; 1055 1099 end; 1056 { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp }1100 { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp; espace = b1.espace } 1057 1101  _ > assert false 1058 1102 end … … 1067 1111  a :: l > 1068 1112 let b = elab a in 1069 elab_comma { edesc = EBinop(Ocomma, accu, b, b.etyp); etyp = b.etyp } l1113 elab_comma { edesc = EBinop(Ocomma, accu, b, b.etyp); etyp = b.etyp; espace = b.espace } l 1070 1114 in elab_comma (elab a1) al 1071 1115 … … 1103 1147 if not (is_scalar_type env b1.etyp) then 1104 1148 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 } 1106 1150 1107 1151 (* Elaboration of binary operators over integers *) … … 1114 1158 error "the second argument of '%s' is not an integer type" msg; 1115 1159 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 } 1117 1161 1118 1162 (* Elaboration of binary operators over arithmetic types *) … … 1125 1169 error "the second argument of '%s' is not an arithmetic type" msg; 1126 1170 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 } 1128 1172 1129 1173 (* Elaboration of shift operators *) … … 1136 1180 error "the second argument of '%s' is not an integer type" msg; 1137 1181 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 } 1139 1183 1140 1184 (* Elaboration of comparisons *) … … 1146 1190  (TInt _  TFloat _), (TInt _  TFloat _) > 1147 1191 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, _) 1153 1197 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, _) 1156 1200 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, _) > 1159 1203 if not (compatible_types ~noattrs:true env ty1 ty2) then 1160 1204 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,_,_) > 1164 1208 warning "comparison between integer and pointer"; 1165 EBinop(op, b1, b2, TPtr( TVoid [], []))1209 EBinop(op, b1, b2, TPtr(sp,TVoid [], [])) 1166 1210  ty1, ty2 > 1167 1211 error "illegal comparison between types@ %a@ and %a" 1168 1212 Cprint.typ b1.etyp Cprint.typ b2.etyp in 1169 { edesc = resdesc; etyp = TInt(IInt, []) }1213 { edesc = resdesc; etyp = TInt(IInt, []); espace = Any } 1170 1214 1171 1215 (* Elaboration of && and  *) … … 1177 1221 if not (is_scalar_type env b2.etyp) then 1178 1222 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 } 1180 1224 1181 1225 (* Typechecking of function arguments *) … … 1276 1320 let rec elab_init loc env ty ile = 1277 1321 match unroll env ty with 1278  TArray( ty_elt, opt_sz, _) >1322  TArray(space, ty_elt, opt_sz, _) > 1279 1323 let rec elab_init_array n accu rem = 1280 1324 match opt_sz, rem with … … 1395 1439 let fixup_typ env ty init = 1396 1440 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) 1399 1443  _ > ty 1400 1444 … … 1422 1466 env' 1423 1467 1424 let enter_or_refine_ident local loc env s sto ty =1468 let enter_or_refine_ident local loc env s sto ty space = 1425 1469 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)) > 1427 1471 let new_ty = 1428 1472 if local then begin … … 1443 1487 sto 1444 1488 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) 1446 1491  Some(id, II_enum v) > 1447 1492 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) 1449 1494  _ > 1450 Env.enter_ident env s sto ty 1495 Env.enter_ident env s sto ty space 1451 1496 1452 1497 let rec enter_decdefs local loc env = function 1453 1498  [] > 1454 1499 ([], env) 1455  (s , sto, ty, init) :: rem >1500  (space, s, sto, ty, init) :: rem > 1456 1501 (* Sanity checks on storage class *) 1457 1502 begin match sto with … … 1468 1513 (* enter ident in environment with declared type, because 1469 1514 initializer can refer to the ident *) 1470 let (id, env1) = enter_or_refine_ident local loc env s sto' ty in1515 let (id, env1) = enter_or_refine_ident local loc env s sto' ty space in 1471 1516 (* process the initializer *) 1472 1517 let (ty', init') = elab_initializer loc env1 ty init in 1473 1518 (* update environment with refined type *) 1474 let env2 = Env.add_ident env1 id sto' ty' in1519 let env2 = Env.add_ident env1 id sto' ty' space in 1475 1520 (* check for incomplete type *) 1476 1521 if sto' <> Storage_extern && incomplete_type env ty' then … … 1482 1527 end else begin 1483 1528 (* Global definition *) 1484 emit_elab (elab_loc loc) (Gdecl(s to, id, ty', init'));1529 emit_elab (elab_loc loc) (Gdecl(space, (sto, id, ty', init'))); 1485 1530 enter_decdefs local loc env2 rem 1486 1531 end … … 1502 1547  _ > fatal_error loc1 "wrong type for function definition" in 1503 1548 (* Enter function in the environment, for recursive references *) 1504 let (fun_id, env1) = enter_or_refine_ident false loc1 env s sto ty in1549 let (fun_id, env1) = enter_or_refine_ident false loc1 env s sto ty Code in 1505 1550 (* Enter parameters in the environment *) 1506 1551 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) 1508 1553 (Env.new_scope env1) params in 1509 1554 (* Elaborate function body *) … … 1544 1589 (* "struct s { ...};" or "union u;" *) 1545 1590  ONLYTYPEDEF(spec, loc) > 1546 let (s to, inl, ty, env') = elab_specifier ~only:true loc env spec in1591 let (space, sto, inl, ty, env') = elab_specifier ~only:true loc env spec in 1547 1592 if sto <> Storage_default  inl then 1548 1593 error loc "Nondefault storage or 'inline' on 'struct' or 'union' declaration";
Note: See TracChangeset
for help on using the changeset viewer.