/usr/share/fpcsrc/2.6.2/compiler/pdecobj.pas is in fpc-source-2.6.2 2.6.2-8.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 | {
Copyright (c) 1998-2002 by Florian Klaempfl
Does object types for Free Pascal
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit pdecobj;
{$i fpcdefs.inc}
interface
uses
cclasses,
globtype,symconst,symtype,symdef;
{ parses a object declaration }
function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef;helpertype:thelpertype) : tobjectdef;
function class_constructor_head:tprocdef;
function class_destructor_head:tprocdef;
function constructor_head:tprocdef;
function destructor_head:tprocdef;
procedure struct_property_dec(is_classproperty:boolean);
implementation
uses
sysutils,cutils,
globals,verbose,systems,tokens,
symbase,symsym,symtable,
node,nld,nmem,ncon,ncnv,ncal,
fmodule,scanner,
pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,ppu
;
const
{ Please leave this here, this module should NOT use
these variables.
Declaring it as string here results in an error when compiling (PFV) }
current_procinfo = 'error';
var
current_objectdef : tobjectdef absolute current_structdef;
function class_constructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_CONSTRUCTOR);
{ must be at same level as in implementation }
parse_proc_head(current_structdef,potype_class_constructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
pd.calcparas;
if (pd.maxparacount>0) then
Message(parser_e_no_paras_for_class_constructor);
consume(_SEMICOLON);
include(current_structdef.objectoptions,oo_has_class_constructor);
current_module.flags:=current_module.flags or uf_classinits;
{ no return value }
pd.returndef:=voidtype;
result:=pd;
end;
function constructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_CONSTRUCTOR);
{ must be at same level as in implementation }
parse_proc_head(current_structdef,potype_constructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
if (cs_constructor_name in current_settings.globalswitches) and
(pd.procsym.name<>'INIT') then
Message(parser_e_constructorname_must_be_init);
consume(_SEMICOLON);
include(current_structdef.objectoptions,oo_has_constructor);
{ Set return type, class and record constructors return the
created instance, helper types return the extended type,
object constructors return boolean }
if is_class(pd.struct) or is_record(pd.struct) then
pd.returndef:=pd.struct
else
if is_objectpascal_helper(pd.struct) then
pd.returndef:=tobjectdef(pd.struct).extendeddef
else
{$ifdef CPU64bitaddr}
pd.returndef:=bool64type;
{$else CPU64bitaddr}
pd.returndef:=bool32type;
{$endif CPU64bitaddr}
result:=pd;
end;
procedure struct_property_dec(is_classproperty:boolean);
var
p : tpropertysym;
begin
{ check for a class, record or helper }
if not((is_class_or_interface_or_dispinterface(current_structdef) or is_record(current_structdef) or is_objectpascal_helper(current_structdef)) or
(not(m_tp7 in current_settings.modeswitches) and (is_object(current_structdef)))) then
Message(parser_e_syntax_error);
consume(_PROPERTY);
p:=read_property_dec(is_classproperty,current_structdef);
consume(_SEMICOLON);
if try_to_consume(_DEFAULT) then
begin
if oo_has_default_property in current_structdef.objectoptions then
message(parser_e_only_one_default_property);
include(current_structdef.objectoptions,oo_has_default_property);
include(p.propoptions,ppo_defaultproperty);
if not(ppo_hasparameters in p.propoptions) then
message(parser_e_property_need_paras);
if (token=_COLON) then
begin
Message(parser_e_field_not_allowed_here);
consume_all_until(_SEMICOLON);
end;
consume(_SEMICOLON);
end;
{ parse possible enumerator modifier }
if try_to_consume(_ENUMERATOR) then
begin
if (token = _ID) then
begin
if pattern='CURRENT' then
begin
if oo_has_enumerator_current in current_structdef.objectoptions then
message(parser_e_only_one_enumerator_current);
if not p.propaccesslist[palt_read].empty then
begin
include(current_structdef.objectoptions,oo_has_enumerator_current);
include(p.propoptions,ppo_enumerator_current);
end
else
Message(parser_e_enumerator_current_is_not_valid) // property has no reader
end
else
Message1(parser_e_invalid_enumerator_identifier, pattern);
consume(token);
end
else
Message(parser_e_enumerator_identifier_required);
consume(_SEMICOLON);
end;
{ hint directives, these can be separated by semicolons here,
that needs to be handled here with a loop (PFV) }
while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do
Consume(_SEMICOLON);
end;
function class_destructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_DESTRUCTOR);
parse_proc_head(current_structdef,potype_class_destructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
pd.calcparas;
if (pd.maxparacount>0) then
Message(parser_e_no_paras_for_class_destructor);
consume(_SEMICOLON);
include(current_structdef.objectoptions,oo_has_class_destructor);
current_module.flags:=current_module.flags or uf_classinits;
{ no return value }
pd.returndef:=voidtype;
result:=pd;
end;
function destructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_DESTRUCTOR);
parse_proc_head(current_structdef,potype_destructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
if (cs_constructor_name in current_settings.globalswitches) and
(pd.procsym.name<>'DONE') then
Message(parser_e_destructorname_must_be_done);
pd.calcparas;
if not(pd.maxparacount=0) and
(m_fpc in current_settings.modeswitches) then
Message(parser_e_no_paras_for_destructor);
consume(_SEMICOLON);
include(current_structdef.objectoptions,oo_has_destructor);
{ no return value }
pd.returndef:=voidtype;
result:=pd;
end;
procedure setinterfacemethodoptions;
var
i : longint;
def : tdef;
begin
include(current_structdef.objectoptions,oo_has_virtual);
for i:=0 to current_structdef.symtable.DefList.count-1 do
begin
def:=tdef(current_structdef.symtable.DefList[i]);
if assigned(def) and
(def.typ=procdef) then
begin
include(tprocdef(def).procoptions,po_virtualmethod);
tprocdef(def).forwarddef:=false;
end;
end;
end;
procedure setobjcclassmethodoptions;
var
i : longint;
def : tdef;
begin
for i:=0 to current_structdef.symtable.DefList.count-1 do
begin
def:=tdef(current_structdef.symtable.DefList[i]);
if assigned(def) and
(def.typ=procdef) then
begin
include(tprocdef(def).procoptions,po_virtualmethod);
end;
end;
end;
procedure handleImplementedInterface(intfdef : tobjectdef);
begin
if not is_interface(intfdef) then
begin
Message1(type_e_interface_type_expected,intfdef.typename);
exit;
end;
if current_objectdef.find_implemented_interface(intfdef)<>nil then
Message1(sym_e_duplicate_id,intfdef.objname^)
else
begin
{ allocate and prepare the GUID only if the class
implements some interfaces. }
if current_objectdef.ImplementedInterfaces.count = 0 then
current_objectdef.prepareguid;
current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
end;
end;
procedure handleImplementedProtocol(intfdef : tobjectdef);
begin
intfdef:=find_real_objcclass_definition(intfdef,false);
if not is_objcprotocol(intfdef) then
begin
Message1(type_e_protocol_type_expected,intfdef.typename);
exit;
end;
if ([oo_is_forward,oo_is_formal] * intfdef.objectoptions <> []) then
begin
Message1(parser_e_forward_protocol_declaration_must_be_resolved,intfdef.objrealname^);
exit;
end;
if current_objectdef.find_implemented_interface(intfdef)<>nil then
Message1(sym_e_duplicate_id,intfdef.objname^)
else
begin
current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef));
end;
end;
procedure readImplementedInterfacesAndProtocols(intf: boolean);
var
hdef : tdef;
begin
while try_to_consume(_COMMA) do
begin
{ use single_type instead of id_type for specialize support }
single_type(hdef,[stoAllowSpecialization,stoParseClassParent]);
if (hdef.typ<>objectdef) then
begin
if intf then
Message1(type_e_interface_type_expected,hdef.typename)
else
Message1(type_e_protocol_type_expected,hdef.typename);
continue;
end;
if intf then
handleImplementedInterface(tobjectdef(hdef))
else
handleImplementedProtocol(tobjectdef(hdef));
end;
end;
procedure readinterfaceiid;
var
p : tnode;
valid : boolean;
begin
p:=comp_expr(true,false);
if p.nodetype=stringconstn then
begin
stringdispose(current_objectdef.iidstr);
current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str));
valid:=string2guid(current_objectdef.iidstr^,current_objectdef.iidguid^);
if (current_objectdef.objecttype in [odt_interfacecom,odt_dispinterface]) and
not valid then
Message(parser_e_improper_guid_syntax);
include(current_structdef.objectoptions,oo_has_valid_guid);
end
else
Message(parser_e_illegal_expression);
p.free;
end;
procedure get_cpp_class_external_status(od: tobjectdef);
var
hs: string;
begin
{ C++ classes can be external -> all methods inside are external
(defined at the class level instead of per method, so that you cannot
define some methods as external and some not)
}
if try_to_consume(_EXTERNAL) then
begin
if token in [_CSTRING,_CWSTRING,_CCHAR,_CWCHAR] then
begin
{ Always add library prefix and suffix to create an uniform name }
hs:=get_stringconst;
if ExtractFileExt(hs)='' then
hs:=ChangeFileExt(hs,target_info.sharedlibext);
if Copy(hs,1,length(target_info.sharedlibprefix))<>target_info.sharedlibprefix then
hs:=target_info.sharedlibprefix+hs;
od.import_lib:=stringdup(hs);
end;
include(od.objectoptions, oo_is_external);
{ check if we shall use another name for the class }
if try_to_consume(_NAME) then
od.objextname:=stringdup(get_stringconst)
else
od.objextname:=stringdup(od.objrealname^);
include(od.objectoptions,oo_is_external);
end
else
od.objextname:=stringdup(od.objrealname^);
{ ToDo: read the namespace of the class (influences the mangled name)}
end;
procedure get_objc_class_or_protocol_external_status(od: tobjectdef);
begin
{ Objective-C classes can be external -> all messages inside are
external (defined at the class level instead of per method, so
that you cannot define some methods as external and some not)
}
if try_to_consume(_EXTERNAL) then
begin
if try_to_consume(_NAME) then
od.objextname:=stringdup(get_stringconst)
else
{ the external name doesn't matter for formally declared
classes, and allowing to specify one would mean that we would
have to check it for consistency with the actual definition
later on }
od.objextname:=stringdup(od.objrealname^);
include(od.objectoptions,oo_is_external);
end
else
od.objextname:=stringdup(od.objrealname^);
end;
procedure parse_object_options;
begin
case current_objectdef.objecttype of
odt_object,odt_class:
begin
while true do
begin
if try_to_consume(_ABSTRACT) then
include(current_structdef.objectoptions,oo_is_abstract)
else
if try_to_consume(_SEALED) then
include(current_structdef.objectoptions,oo_is_sealed)
else
break;
end;
if [oo_is_abstract, oo_is_sealed] * current_structdef.objectoptions = [oo_is_abstract, oo_is_sealed] then
Message(parser_e_abstract_and_sealed_conflict);
end;
odt_cppclass:
get_cpp_class_external_status(current_objectdef);
odt_objcclass,odt_objcprotocol,odt_objccategory:
get_objc_class_or_protocol_external_status(current_objectdef);
odt_helper: ; // nothing
end;
end;
procedure parse_parent_classes;
var
intfchildof,
childof : tobjectdef;
hdef : tdef;
hasparentdefined : boolean;
begin
childof:=nil;
intfchildof:=nil;
hasparentdefined:=false;
{ reads the parent class }
if (token=_LKLAMMER) or
is_objccategory(current_structdef) then
begin
consume(_LKLAMMER);
{ use single_type instead of id_type for specialize support }
single_type(hdef,[stoAllowSpecialization, stoParseClassParent]);
if (not assigned(hdef)) or
(hdef.typ<>objectdef) then
begin
if assigned(hdef) then
Message1(type_e_class_type_expected,hdef.typename)
else if is_objccategory(current_structdef) then
{ a category must specify the class to extend }
Message(type_e_objcclass_type_expected);
end
else
begin
childof:=tobjectdef(hdef);
{ a mix of class, interfaces, objects and cppclasses
isn't allowed }
case current_objectdef.objecttype of
odt_class:
if not(is_class(childof)) then
begin
if is_interface(childof) then
begin
{ we insert the interface after the child
is set, see below
}
intfchildof:=childof;
childof:=class_tobject;
end
else
Message(parser_e_mix_of_classes_and_objects);
end
else
if oo_is_sealed in childof.objectoptions then
Message1(parser_e_sealed_descendant,childof.typename);
odt_interfacecorba,
odt_interfacecom:
begin
if not(is_interface(childof)) then
Message(parser_e_mix_of_classes_and_objects);
current_objectdef.objecttype:=childof.objecttype;
end;
odt_cppclass:
if not(is_cppclass(childof)) then
Message(parser_e_mix_of_classes_and_objects);
odt_objcclass:
if not(is_objcclass(childof) or
is_objccategory(childof)) then
begin
if is_objcprotocol(childof) then
begin
if not(oo_is_classhelper in current_structdef.objectoptions) then
begin
intfchildof:=childof;
childof:=nil;
CGMessage(parser_h_no_objc_parent);
end
else
{ a category must specify the class to extend }
CGMessage(type_e_objcclass_type_expected);
end
else
Message(parser_e_mix_of_classes_and_objects);
end
else
childof:=find_real_objcclass_definition(childof,true);
odt_objcprotocol:
begin
if not(is_objcprotocol(childof)) then
Message(parser_e_mix_of_classes_and_objects);
intfchildof:=childof;
childof:=nil;
end;
odt_object:
if not(is_object(childof)) then
Message(parser_e_mix_of_classes_and_objects)
else
if oo_is_sealed in childof.objectoptions then
Message1(parser_e_sealed_descendant,childof.typename);
odt_dispinterface:
Message(parser_e_dispinterface_cant_have_parent);
odt_helper:
if not is_objectpascal_helper(childof) then
begin
Message(type_e_helper_type_expected);
childof:=nil;
end;
end;
end;
hasparentdefined:=true;
end;
{ if no parent class, then a class get tobject as parent }
if not assigned(childof) then
begin
case current_objectdef.objecttype of
odt_class:
if current_objectdef<>class_tobject then
childof:=class_tobject;
odt_interfacecom:
if current_objectdef<>interface_iunknown then
childof:=interface_iunknown;
odt_dispinterface:
childof:=interface_idispatch;
odt_objcclass:
CGMessage(parser_h_no_objc_parent);
end;
end;
if assigned(childof) then
begin
{ Forbid not completly defined objects to be used as parents. This will
also prevent circular loops of classes, because we set the forward flag
at the start of the new definition and will reset it below after the
parent has been set }
if (oo_is_forward in childof.objectoptions) then
Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^)
else if not(oo_is_formal in childof.objectoptions) then
current_objectdef.set_parent(childof)
else
Message1(sym_e_objc_formal_class_not_resolved,childof.objrealname^);
end;
{ remove forward flag, is resolved }
exclude(current_structdef.objectoptions,oo_is_forward);
if hasparentdefined then
begin
if current_objectdef.objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then
begin
if assigned(intfchildof) then
if current_objectdef.objecttype=odt_class then
handleImplementedInterface(intfchildof)
else
handleImplementedProtocol(intfchildof);
readImplementedInterfacesAndProtocols(current_objectdef.objecttype=odt_class);
end;
consume(_RKLAMMER);
end;
end;
procedure parse_extended_type(helpertype:thelpertype);
var
hdef: tdef;
begin
if not is_objectpascal_helper(current_structdef) then
Internalerror(2011021103);
if helpertype=ht_none then
Internalerror(2011021001);
consume(_FOR);
single_type(hdef,[stoParseClassParent]);
if (not assigned(hdef)) or
not (hdef.typ in [objectdef,recorddef]) then
begin
if helpertype=ht_class then
Message1(type_e_class_type_expected,hdef.typename)
else
if helpertype=ht_record then
Message1(type_e_record_type_expected,hdef.typename);
end
else
begin
case helpertype of
ht_class:
begin
if not is_class(hdef) then
Message1(type_e_class_type_expected,hdef.typename);
{ a class helper must extend the same class or a subclass
of the class extended by the parent class helper }
if assigned(current_objectdef.childof) then
begin
if not is_class(current_objectdef.childof.extendeddef) then
Internalerror(2011021101);
if not hdef.is_related(current_objectdef.childof.extendeddef) then
Message1(type_e_class_helper_must_extend_subclass,current_objectdef.childof.extendeddef.typename);
end;
end;
ht_record:
begin
if not is_record(hdef) then
Message1(type_e_record_type_expected,hdef.typename);
{ a record helper must extend the same record as the
parent helper }
if assigned(current_objectdef.childof) then
begin
if not is_record(current_objectdef.childof.extendeddef) then
Internalerror(2011021102);
if hdef<>current_objectdef.childof.extendeddef then
Message1(type_e_record_helper_must_extend_same_record,current_objectdef.childof.extendeddef.typename);
end;
end;
else
hdef:=nil;
end;
end;
if assigned(hdef) then
current_objectdef.extendeddef:=hdef
else
current_objectdef.extendeddef:=generrordef;
end;
procedure parse_guid;
begin
{ read GUID }
if (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
try_to_consume(_LECKKLAMMER) then
begin
readinterfaceiid;
consume(_RECKKLAMMER);
end
else if (current_objectdef.objecttype=odt_dispinterface) then
message(parser_e_dispinterface_needs_a_guid);
end;
procedure parse_object_members;
procedure chkobjc(pd: tprocdef);
begin
if is_objc_class_or_protocol(pd.struct) then
begin
include(pd.procoptions,po_objc);
end;
end;
procedure chkcpp(pd:tprocdef);
begin
{ nothing currently }
end;
procedure maybe_parse_hint_directives(pd:tprocdef);
var
dummysymoptions : tsymoptions;
deprecatedmsg : pshortstring;
begin
dummysymoptions:=[];
deprecatedmsg:=nil;
while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
Consume(_SEMICOLON);
if assigned(pd) then
begin
pd.symoptions:=pd.symoptions+dummysymoptions;
pd.deprecatedmsg:=deprecatedmsg;
end
else
stringdispose(deprecatedmsg);
end;
var
pd : tprocdef;
has_destructor,
oldparse_only: boolean;
object_member_blocktype : tblock_type;
fields_allowed, is_classdef, classfields: boolean;
vdoptions: tvar_dec_options;
begin
{ empty class declaration ? }
if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and
(token=_SEMICOLON) then
exit;
{ in "publishable" classes the default access type is published }
if (oo_can_have_published in current_structdef.objectoptions) then
current_structdef.symtable.currentvisibility:=vis_published
else
current_structdef.symtable.currentvisibility:=vis_public;
has_destructor:=false;
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
repeat
case token of
_TYPE :
begin
if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then
Message(parser_e_type_var_const_only_in_records_and_classes);
consume(_TYPE);
object_member_blocktype:=bt_type;
end;
_VAR :
begin
if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then
Message(parser_e_type_var_const_only_in_records_and_classes);
consume(_VAR);
fields_allowed:=true;
object_member_blocktype:=bt_general;
classfields:=is_classdef;
is_classdef:=false;
end;
_CONST:
begin
if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then
Message(parser_e_type_var_const_only_in_records_and_classes);
consume(_CONST);
object_member_blocktype:=bt_const;
end;
_ID :
begin
if is_objcprotocol(current_structdef) and
((idtoken=_REQUIRED) or
(idtoken=_OPTIONAL)) then
begin
current_structdef.symtable.currentlyoptional:=(idtoken=_OPTIONAL);
consume(idtoken)
end
else case idtoken of
_PRIVATE :
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PRIVATE);
current_structdef.symtable.currentvisibility:=vis_private;
include(current_structdef.objectoptions,oo_has_private);
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
end;
_PROTECTED :
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PROTECTED);
current_structdef.symtable.currentvisibility:=vis_protected;
include(current_structdef.objectoptions,oo_has_protected);
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
end;
_PUBLIC :
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLIC);
current_structdef.symtable.currentvisibility:=vis_public;
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
end;
_PUBLISHED :
begin
{ we've to check for a pushlished section in non- }
{ publishable classes later, if a real declaration }
{ this is the way, delphi does it }
if is_interface(current_structdef) then
Message(parser_e_no_access_specifier_in_interfaces);
{ Objective-C classes do not support "published",
as basically everything is published. }
if is_objc_class_or_protocol(current_structdef) then
Message(parser_e_no_objc_published);
consume(_PUBLISHED);
current_structdef.symtable.currentvisibility:=vis_published;
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
end;
_STRICT :
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) then
Message(parser_e_no_access_specifier_in_interfaces);
consume(_STRICT);
if token=_ID then
begin
case idtoken of
_PRIVATE:
begin
consume(_PRIVATE);
current_structdef.symtable.currentvisibility:=vis_strictprivate;
include(current_structdef.objectoptions,oo_has_strictprivate);
end;
_PROTECTED:
begin
consume(_PROTECTED);
current_structdef.symtable.currentvisibility:=vis_strictprotected;
include(current_structdef.objectoptions,oo_has_strictprotected);
end;
else
message(parser_e_protected_or_private_expected);
end;
end
else
message(parser_e_protected_or_private_expected);
fields_allowed:=true;
is_classdef:=false;
classfields:=false;
object_member_blocktype:=bt_general;
end
else
begin
if object_member_blocktype=bt_general then
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) or
is_objectpascal_helper(current_structdef) then
Message(parser_e_no_vars_in_interfaces);
if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
if (not fields_allowed) then
Message(parser_e_field_not_allowed_here);
vdoptions:=[vd_object];
if classfields then
include(vdoptions,vd_class);
read_record_fields(vdoptions);
end
else if object_member_blocktype=bt_type then
types_dec(true)
else if object_member_blocktype=bt_const then
consts_dec(true)
else
internalerror(201001110);
end;
end;
end;
_PROPERTY :
begin
struct_property_dec(is_classdef);
fields_allowed:=false;
is_classdef:=false;
end;
_CLASS:
begin
is_classdef:=false;
{ read class method/field/property }
consume(_CLASS);
{ class modifier is only allowed for procedures, functions, }
{ constructors, destructors, fields and properties }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR]) then
Message(parser_e_procedure_or_function_expected);
if is_interface(current_structdef) then
Message(parser_e_no_static_method_in_interfaces)
else
{ class methods are also allowed for Objective-C protocols }
is_classdef:=true;
end;
_PROCEDURE,
_FUNCTION:
begin
if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
oldparse_only:=parse_only;
parse_only:=true;
pd:=parse_proc_dec(is_classdef,current_structdef);
{ this is for error recovery as well as forward }
{ interface mappings, i.e. mapping to a method }
{ which isn't declared yet }
if assigned(pd) then
begin
parse_object_proc_directives(pd);
{ check if dispid is set }
if is_dispinterface(pd.struct) and not (po_dispid in pd.procoptions) then
begin
pd.dispid:=tobjectdef(pd.struct).get_next_dispid;
include(pd.procoptions, po_dispid);
end;
{ all Macintosh Object Pascal methods are virtual. }
{ this can't be a class method, because macpas mode }
{ has no m_class }
if (m_mac in current_settings.modeswitches) then
include(pd.procoptions,po_virtualmethod);
{ for record helpers only static class methods are allowed }
if is_objectpascal_helper(current_structdef) and
is_record(current_objectdef.extendeddef) and
is_classdef and not (po_staticmethod in pd.procoptions) then
MessagePos(pd.fileinfo, parser_e_class_methods_only_static_in_records);
handle_calling_convention(pd);
{ add definition to procsym }
proc_add_definition(pd);
{ add procdef options to objectdef options }
if (po_msgint in pd.procoptions) then
include(current_structdef.objectoptions,oo_has_msgint);
if (po_msgstr in pd.procoptions) then
include(current_structdef.objectoptions,oo_has_msgstr);
if (po_virtualmethod in pd.procoptions) then
include(current_structdef.objectoptions,oo_has_virtual);
chkcpp(pd);
chkobjc(pd);
end;
maybe_parse_hint_directives(pd);
parse_only:=oldparse_only;
fields_allowed:=false;
is_classdef:=false;
end;
_CONSTRUCTOR :
begin
if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
if not is_classdef and not(current_structdef.symtable.currentvisibility in [vis_public,vis_published]) then
Message(parser_w_constructor_should_be_public);
if is_interface(current_structdef) then
Message(parser_e_no_con_des_in_interfaces);
{ Objective-C does not know the concept of a constructor }
if is_objc_class_or_protocol(current_structdef) then
Message(parser_e_objc_no_constructor_destructor);
if is_objectpascal_helper(current_structdef) then
if is_classdef then
{ class constructors are not allowed in class helpers }
Message(parser_e_no_class_constructor_in_helpers)
else
if is_record(current_objectdef.extendeddef) then
{ as long as constructors aren't allowed in records they
aren't allowed in helpers either }
Message(parser_e_no_constructor_in_records);
{ only 1 class constructor is allowed }
if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
oldparse_only:=parse_only;
parse_only:=true;
if is_classdef then
pd:=class_constructor_head
else
pd:=constructor_head;
parse_object_proc_directives(pd);
handle_calling_convention(pd);
{ add definition to procsym }
proc_add_definition(pd);
{ add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then
include(current_structdef.objectoptions,oo_has_virtual);
chkcpp(pd);
maybe_parse_hint_directives(pd);
parse_only:=oldparse_only;
fields_allowed:=false;
is_classdef:=false;
end;
_DESTRUCTOR :
begin
if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
if not is_classdef then
if has_destructor then
Message(parser_n_only_one_destructor)
else
has_destructor:=true;
if is_interface(current_structdef) then
Message(parser_e_no_con_des_in_interfaces);
{ (class) destructors are not allowed in class helpers }
if is_objectpascal_helper(current_structdef) then
Message(parser_e_no_destructor_in_records);
if not is_classdef and (current_structdef.symtable.currentvisibility<>vis_public) then
Message(parser_w_destructor_should_be_public);
{ Objective-C does not know the concept of a destructor }
if is_objc_class_or_protocol(current_structdef) then
Message(parser_e_objc_no_constructor_destructor);
{ only 1 class destructor is allowed }
if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
oldparse_only:=parse_only;
parse_only:=true;
if is_classdef then
pd:=class_destructor_head
else
pd:=destructor_head;
parse_object_proc_directives(pd);
handle_calling_convention(pd);
{ add definition to procsym }
proc_add_definition(pd);
{ add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then
include(current_structdef.objectoptions,oo_has_virtual);
chkcpp(pd);
maybe_parse_hint_directives(pd);
parse_only:=oldparse_only;
fields_allowed:=false;
is_classdef:=false;
end;
_END :
begin
consume(_END);
break;
end;
else
consume(_ID); { Give a ident expected message, like tp7 }
end;
until false;
end;
function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef;helpertype:thelpertype) : tobjectdef;
var
old_current_structdef: tabstractrecorddef;
old_current_genericdef,
old_current_specializedef: tstoreddef;
old_parse_generic: boolean;
list: TFPObjectList;
s: String;
st: TSymtable;
begin
old_current_structdef:=current_structdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
old_parse_generic:=parse_generic;
current_structdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
{ objects and class types can't be declared local }
if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
not assigned(genericlist) then
Message(parser_e_no_local_objects);
{ reuse forward objectdef? }
if assigned(fd) then
begin
if fd.objecttype<>objecttype then
begin
Message(parser_e_forward_mismatch);
{ recover }
current_structdef:=tobjectdef.create(current_objectdef.objecttype,n,nil);
include(current_structdef.objectoptions,oo_is_forward);
end
else
current_structdef:=fd
end
else
begin
{ anonym objects aren't allow (o : object a : longint; end;) }
if n='' then
Message(parser_f_no_anonym_objects);
{ create new class }
current_structdef:=tobjectdef.create(objecttype,n,nil);
{ include always the forward flag, it'll be removed after the parent class have been
added. This is to prevent circular childof loops }
include(current_structdef.objectoptions,oo_is_forward);
if (cs_compilesystem in current_settings.moduleswitches) then
begin
case current_objectdef.objecttype of
odt_interfacecom :
if (current_structdef.objname^='IUNKNOWN') then
interface_iunknown:=current_objectdef
else
if (current_structdef.objname^='IDISPATCH') then
interface_idispatch:=current_objectdef;
odt_class :
if (current_structdef.objname^='TOBJECT') then
class_tobject:=current_objectdef;
end;
end;
if (current_module.modulename^='OBJCBASE') then
begin
case current_objectdef.objecttype of
odt_objcclass:
if (current_objectdef.objname^='Protocol') then
objc_protocoltype:=current_objectdef;
end;
end;
end;
{ usage of specialized type inside its generic template }
if assigned(genericdef) then
current_specializedef:=current_structdef
{ reject declaration of generic class inside generic class }
else if assigned(genericlist) then
current_genericdef:=current_structdef;
{ set published flag in $M+ mode, it can also be inherited and will
be added when the parent class set with tobjectdef.set_parent (PFV) }
if (cs_generate_rtti in current_settings.localswitches) and
(current_objectdef.objecttype in [odt_interfacecom,odt_class,odt_helper]) then
include(current_structdef.objectoptions,oo_can_have_published);
{ Objective-C objectdefs can be "formal definitions", in which case
the syntax is "type tc = objcclass external;" -> we have to parse
its object options (external) already here, to make sure that such
definitions are recognised as formal defs }
if objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory] then
parse_object_options;
{ forward def? }
if not assigned(fd) and
(token=_SEMICOLON) then
begin
{ add to the list of definitions to check that the forward
is resolved. this is required for delphi mode }
current_module.checkforwarddefs.add(current_structdef);
end
else
begin
{ change objccategories into objcclass helpers }
if (objecttype=odt_objccategory) then
begin
current_objectdef.objecttype:=odt_objcclass;
include(current_structdef.objectoptions,oo_is_classhelper);
end;
{ include the class helper flag for Object Pascal helpers }
if (objecttype=odt_helper) then
include(current_objectdef.objectoptions,oo_is_classhelper);
{ parse list of options (abstract / sealed) }
if not(objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory]) then
parse_object_options;
symtablestack.push(current_structdef.symtable);
insert_generic_parameter_types(current_structdef,genericdef,genericlist);
parse_generic:=(df_generic in current_structdef.defoptions);
{ parse list of parent classes }
{ for record helpers in mode Delphi this is not allowed }
if not (is_objectpascal_helper(current_objectdef) and
(m_delphi in current_settings.modeswitches) and
(helpertype=ht_record)) then
parse_parent_classes
else
{ remove forward flag, is resolved (this is normally done inside
parse_parent_classes) }
exclude(current_structdef.objectoptions,oo_is_forward);
{ parse extended type for helpers }
if is_objectpascal_helper(current_structdef) then
parse_extended_type(helpertype);
{ parse optional GUID for interfaces }
parse_guid;
{ parse and insert object members }
parse_object_members;
symtablestack.pop(current_structdef.symtable);
end;
{ generate vmt space if needed }
if not(oo_has_vmt in current_structdef.objectoptions) and
not(oo_is_forward in current_structdef.objectoptions) and
(
([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_structdef.objectoptions<>[]) or
(current_objectdef.objecttype in [odt_class])
) then
current_objectdef.insertvmt;
{ for implemented classes with a vmt check if there is a constructor }
if (oo_has_vmt in current_structdef.objectoptions) and
not(oo_is_forward in current_structdef.objectoptions) and
not(oo_has_constructor in current_structdef.objectoptions) and
not is_objc_class_or_protocol(current_structdef) then
Message1(parser_w_virtual_without_constructor,current_structdef.objrealname^);
if is_interface(current_structdef) or
is_objcprotocol(current_structdef) then
setinterfacemethodoptions
else if is_objcclass(current_structdef) then
setobjcclassmethodoptions;
{ if this helper is defined in the implementation section of the unit
or inside the main project file, the extendeddefs list of the current
module must be updated (it will be removed when poping the symtable) }
if is_objectpascal_helper(current_structdef) and
(current_objectdef.extendeddef.typ in [recorddef,objectdef]) then
begin
{ the topmost symtable must be a static symtable }
st:=current_structdef.owner;
while st.symtabletype in [objectsymtable,recordsymtable] do
st:=st.defowner.owner;
if st.symtabletype=staticsymtable then
begin
s:=make_mangledname('',tabstractrecorddef(current_objectdef.extendeddef).symtable,'');
list:=TFPObjectList(current_module.extendeddefs.Find(s));
if not assigned(list) then
begin
list:=TFPObjectList.Create(false);
current_module.extendeddefs.Add(s, list);
end;
list.add(current_structdef);
end;
end;
tabstractrecordsymtable(current_objectdef.symtable).addalignmentpadding;
{ return defined objectdef }
result:=current_objectdef;
{ restore old state }
current_structdef:=old_current_structdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
parse_generic:=old_parse_generic;
end;
end.
|