pexpr.pas 94 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Does parsing of expression for Free Pascal
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pexpr;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. symtype,symdef,symbase,
  23. node,ncal,
  24. globtype,globals;
  25. { reads a whole expression }
  26. function expr : tnode;
  27. { reads an expression without assignements and .. }
  28. function comp_expr(accept_equal : boolean):tnode;
  29. { reads a single factor }
  30. function factor(getaddr : boolean) : tnode;
  31. procedure string_dec(var t: ttype);
  32. procedure symlist_to_node(var p1:tnode;st:tsymtable;pl:tsymlist);
  33. function node_to_symlist(p1:tnode):tsymlist;
  34. function parse_paras(__colon,in_prop_paras : boolean) : tnode;
  35. { the ID token has to be consumed before calling this function }
  36. procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callflags:tcallnodeflags);
  37. {$ifdef int64funcresok}
  38. function get_intconst:TConstExprInt;
  39. {$else int64funcresok}
  40. function get_intconst:longint;
  41. {$endif int64funcresok}
  42. function get_stringconst:string;
  43. implementation
  44. uses
  45. { common }
  46. cutils,
  47. { global }
  48. tokens,verbose,
  49. systems,widestr,
  50. { symtable }
  51. symconst,symtable,symsym,defutil,defcmp,
  52. { module }
  53. fmodule,ppu,
  54. { pass 1 }
  55. pass_1,htypechk,
  56. nmat,nadd,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
  57. { parser }
  58. scanner,
  59. pbase,pinline,
  60. { codegen }
  61. cgbase,procinfo,cpuinfo
  62. ;
  63. { sub_expr(opmultiply) is need to get -1 ** 4 to be
  64. read as - (1**4) and not (-1)**4 PM }
  65. type
  66. Toperator_precedence=(opcompare,opaddition,opmultiply,oppower);
  67. const
  68. highest_precedence = oppower;
  69. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):tnode;forward;
  70. const
  71. { true, if the inherited call is anonymous }
  72. anon_inherited : boolean = false;
  73. procedure string_dec(var t: ttype);
  74. { reads a string type with optional length }
  75. { and returns a pointer to the string }
  76. { definition }
  77. var
  78. p : tnode;
  79. begin
  80. t:=cshortstringtype;
  81. consume(_STRING);
  82. if try_to_consume(_LECKKLAMMER) then
  83. begin
  84. p:=comp_expr(true);
  85. if not is_constintnode(p) then
  86. begin
  87. Message(parser_e_illegal_expression);
  88. { error recovery }
  89. consume(_RECKKLAMMER);
  90. end
  91. else
  92. begin
  93. if (tordconstnode(p).value<=0) then
  94. begin
  95. Message(parser_e_invalid_string_size);
  96. tordconstnode(p).value:=255;
  97. end;
  98. consume(_RECKKLAMMER);
  99. if tordconstnode(p).value>255 then
  100. begin
  101. { longstring is currently unsupported (CEC)! }
  102. { t.setdef(tstringdef.createlong(tordconstnode(p).value))}
  103. Message(parser_e_invalid_string_size);
  104. tordconstnode(p).value:=255;
  105. t.setdef(tstringdef.createshort(tordconstnode(p).value));
  106. end
  107. else
  108. if tordconstnode(p).value<>255 then
  109. t.setdef(tstringdef.createshort(tordconstnode(p).value));
  110. end;
  111. p.free;
  112. end
  113. else
  114. begin
  115. if cs_ansistrings in aktlocalswitches then
  116. {$ifdef ansistring_bits}
  117. case aktansistring_bits of
  118. sb_16:
  119. t:=cansistringtype16;
  120. sb_32:
  121. t:=cansistringtype32;
  122. sb_64:
  123. t:=cansistringtype64;
  124. end
  125. {$else}
  126. t:=cansistringtype
  127. {$endif}
  128. else
  129. t:=cshortstringtype;
  130. end;
  131. end;
  132. procedure symlist_to_node(var p1:tnode;st:tsymtable;pl:tsymlist);
  133. var
  134. plist : psymlistitem;
  135. begin
  136. plist:=pl.firstsym;
  137. while assigned(plist) do
  138. begin
  139. case plist^.sltype of
  140. sl_load :
  141. begin
  142. if not assigned(st) then
  143. st:=plist^.sym.owner;
  144. { p1 can already contain the loadnode of
  145. the class variable. When there is no tree yet we
  146. may need to load it for with or objects }
  147. if not assigned(p1) then
  148. begin
  149. case st.symtabletype of
  150. withsymtable :
  151. p1:=tnode(twithsymtable(st).withrefnode).getcopy;
  152. objectsymtable :
  153. p1:=load_self_node;
  154. end;
  155. end;
  156. if assigned(p1) then
  157. p1:=csubscriptnode.create(plist^.sym,p1)
  158. else
  159. p1:=cloadnode.create(plist^.sym,st);
  160. end;
  161. sl_subscript :
  162. p1:=csubscriptnode.create(plist^.sym,p1);
  163. sl_typeconv :
  164. p1:=ctypeconvnode.create_explicit(p1,plist^.tt);
  165. sl_absolutetype :
  166. begin
  167. p1:=ctypeconvnode.create(p1,plist^.tt);
  168. include(p1.flags,nf_absolute);
  169. end;
  170. sl_vec :
  171. p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,s32inttype,true));
  172. else
  173. internalerror(200110205);
  174. end;
  175. plist:=plist^.next;
  176. end;
  177. end;
  178. function node_to_symlist(p1:tnode):tsymlist;
  179. var
  180. sl : tsymlist;
  181. procedure addnode(p:tnode);
  182. begin
  183. case p.nodetype of
  184. subscriptn :
  185. begin
  186. addnode(tsubscriptnode(p).left);
  187. sl.addsym(sl_subscript,tsubscriptnode(p).vs);
  188. end;
  189. typeconvn :
  190. begin
  191. addnode(ttypeconvnode(p).left);
  192. if nf_absolute in ttypeconvnode(p).flags then
  193. sl.addtype(sl_absolutetype,ttypeconvnode(p).totype)
  194. else
  195. sl.addtype(sl_typeconv,ttypeconvnode(p).totype);
  196. end;
  197. vecn :
  198. begin
  199. addnode(tvecnode(p).left);
  200. if tvecnode(p).right.nodetype=ordconstn then
  201. sl.addconst(sl_vec,tordconstnode(tvecnode(p).right).value)
  202. else
  203. begin
  204. Message(parser_e_illegal_expression);
  205. { recovery }
  206. sl.addconst(sl_vec,0);
  207. end;
  208. end;
  209. loadn :
  210. sl.addsym(sl_load,tloadnode(p).symtableentry);
  211. else
  212. internalerror(200310282);
  213. end;
  214. end;
  215. begin
  216. sl:=tsymlist.create;
  217. addnode(p1);
  218. result:=sl;
  219. end;
  220. function parse_paras(__colon,in_prop_paras : boolean) : tnode;
  221. var
  222. p1,p2 : tnode;
  223. end_of_paras : ttoken;
  224. prev_in_args : boolean;
  225. old_allow_array_constructor : boolean;
  226. begin
  227. if in_prop_paras then
  228. end_of_paras:=_RECKKLAMMER
  229. else
  230. end_of_paras:=_RKLAMMER;
  231. if token=end_of_paras then
  232. begin
  233. parse_paras:=nil;
  234. exit;
  235. end;
  236. { save old values }
  237. prev_in_args:=in_args;
  238. old_allow_array_constructor:=allow_array_constructor;
  239. { set para parsing values }
  240. in_args:=true;
  241. inc(parsing_para_level);
  242. allow_array_constructor:=true;
  243. p2:=nil;
  244. repeat
  245. p1:=comp_expr(true);
  246. p2:=ccallparanode.create(p1,p2);
  247. { it's for the str(l:5,s); }
  248. if __colon and (token=_COLON) then
  249. begin
  250. consume(_COLON);
  251. p1:=comp_expr(true);
  252. p2:=ccallparanode.create(p1,p2);
  253. include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
  254. if try_to_consume(_COLON) then
  255. begin
  256. p1:=comp_expr(true);
  257. p2:=ccallparanode.create(p1,p2);
  258. include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
  259. end
  260. end;
  261. until not try_to_consume(_COMMA);
  262. allow_array_constructor:=old_allow_array_constructor;
  263. dec(parsing_para_level);
  264. in_args:=prev_in_args;
  265. parse_paras:=p2;
  266. end;
  267. function gen_c_style_operator(ntyp:tnodetype;p1,p2:tnode) : tnode;
  268. var
  269. hp : tnode;
  270. htype : ttype;
  271. temp : ttempcreatenode;
  272. newstatement : tstatementnode;
  273. begin
  274. { Properties are not allowed, because the write can
  275. be different from the read }
  276. if (nf_isproperty in p1.flags) then
  277. begin
  278. Message(type_e_variable_id_expected);
  279. { We can continue with the loading,
  280. it'll not create errors. Only the expected
  281. result can be wrong }
  282. end;
  283. hp:=p1;
  284. while assigned(hp) and
  285. (hp.nodetype in [derefn,subscriptn,vecn,typeconvn]) do
  286. hp:=tunarynode(hp).left;
  287. if not assigned(hp) then
  288. internalerror(200410121);
  289. if (hp.nodetype=calln) then
  290. begin
  291. resulttypepass(p1);
  292. result:=internalstatements(newstatement);
  293. htype.setdef(tpointerdef.create(p1.resulttype));
  294. temp:=ctempcreatenode.create(htype,sizeof(aint),tt_persistent,false);
  295. addstatement(newstatement,temp);
  296. addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),caddrnode.create_internal(p1)));
  297. addstatement(newstatement,cassignmentnode.create(
  298. cderefnode.create(ctemprefnode.create(temp)),
  299. caddnode.create(ntyp,
  300. cderefnode.create(ctemprefnode.create(temp)),
  301. p2)));
  302. addstatement(newstatement,ctempdeletenode.create(temp));
  303. end
  304. else
  305. result:=cassignmentnode.create(p1,caddnode.create(ntyp,p1.getcopy,p2));
  306. end;
  307. function statement_syssym(l : longint) : tnode;
  308. var
  309. p1,p2,paras : tnode;
  310. err,
  311. prev_in_args : boolean;
  312. begin
  313. prev_in_args:=in_args;
  314. case l of
  315. in_new_x :
  316. begin
  317. if afterassignment or in_args then
  318. statement_syssym:=new_function
  319. else
  320. statement_syssym:=new_dispose_statement(true);
  321. end;
  322. in_dispose_x :
  323. begin
  324. statement_syssym:=new_dispose_statement(false);
  325. end;
  326. in_ord_x :
  327. begin
  328. consume(_LKLAMMER);
  329. in_args:=true;
  330. p1:=comp_expr(true);
  331. consume(_RKLAMMER);
  332. p1:=geninlinenode(in_ord_x,false,p1);
  333. statement_syssym := p1;
  334. end;
  335. in_exit :
  336. begin
  337. if try_to_consume(_LKLAMMER) then
  338. begin
  339. if not (m_mac in aktmodeswitches) then
  340. begin
  341. p1:=comp_expr(true);
  342. consume(_RKLAMMER);
  343. if (block_type=bt_except) then
  344. begin
  345. Message(parser_e_exit_with_argument_not__possible);
  346. { recovery }
  347. p1.free;
  348. p1:=nil;
  349. end
  350. else if (not assigned(current_procinfo) or
  351. is_void(current_procinfo.procdef.rettype.def)) then
  352. begin
  353. Message(parser_e_void_function);
  354. { recovery }
  355. p1.free;
  356. p1:=nil;
  357. end;
  358. end
  359. else
  360. begin
  361. if not (current_procinfo.procdef.procsym.name = pattern) then
  362. Message(parser_e_macpas_exit_wrong_param);
  363. consume(_ID);
  364. consume(_RKLAMMER);
  365. p1:=nil;
  366. end
  367. end
  368. else
  369. p1:=nil;
  370. statement_syssym:=cexitnode.create(p1);
  371. end;
  372. in_break :
  373. begin
  374. if not (m_mac in aktmodeswitches) then
  375. statement_syssym:=cbreaknode.create
  376. else
  377. begin
  378. Message1(sym_e_id_not_found, orgpattern);
  379. statement_syssym:=cerrornode.create;
  380. end;
  381. end;
  382. in_continue :
  383. begin
  384. if not (m_mac in aktmodeswitches) then
  385. statement_syssym:=ccontinuenode.create
  386. else
  387. begin
  388. Message1(sym_e_id_not_found, orgpattern);
  389. statement_syssym:=cerrornode.create;
  390. end;
  391. end;
  392. in_leave :
  393. begin
  394. if m_mac in aktmodeswitches then
  395. statement_syssym:=cbreaknode.create
  396. else
  397. begin
  398. Message1(sym_e_id_not_found, orgpattern);
  399. statement_syssym:=cerrornode.create;
  400. end;
  401. end;
  402. in_cycle :
  403. begin
  404. if m_mac in aktmodeswitches then
  405. statement_syssym:=ccontinuenode.create
  406. else
  407. begin
  408. Message1(sym_e_id_not_found, orgpattern);
  409. statement_syssym:=cerrornode.create;
  410. end;
  411. end;
  412. in_typeof_x :
  413. begin
  414. consume(_LKLAMMER);
  415. in_args:=true;
  416. p1:=comp_expr(true);
  417. consume(_RKLAMMER);
  418. if p1.nodetype=typen then
  419. ttypenode(p1).allowed:=true;
  420. { Allow classrefdef, which is required for
  421. Typeof(self) in static class methods }
  422. if (p1.resulttype.def.deftype = objectdef) or
  423. (assigned(current_procinfo) and
  424. ((po_classmethod in current_procinfo.procdef.procoptions) or
  425. (po_staticmethod in current_procinfo.procdef.procoptions)) and
  426. (p1.resulttype.def.deftype=classrefdef)) then
  427. statement_syssym:=geninlinenode(in_typeof_x,false,p1)
  428. else
  429. begin
  430. Message(parser_e_class_id_expected);
  431. p1.destroy;
  432. statement_syssym:=cerrornode.create;
  433. end;
  434. end;
  435. in_sizeof_x :
  436. begin
  437. consume(_LKLAMMER);
  438. in_args:=true;
  439. p1:=comp_expr(true);
  440. consume(_RKLAMMER);
  441. if (p1.nodetype<>typen) and
  442. (
  443. (is_object(p1.resulttype.def) and
  444. (oo_has_constructor in tobjectdef(p1.resulttype.def).objectoptions)) or
  445. is_open_array(p1.resulttype.def) or
  446. is_open_string(p1.resulttype.def)
  447. ) then
  448. statement_syssym:=geninlinenode(in_sizeof_x,false,p1)
  449. else
  450. begin
  451. statement_syssym:=cordconstnode.create(p1.resulttype.def.size,sinttype,true);
  452. { p1 not needed !}
  453. p1.destroy;
  454. end;
  455. end;
  456. in_typeinfo_x :
  457. begin
  458. consume(_LKLAMMER);
  459. in_args:=true;
  460. p1:=comp_expr(true);
  461. { When reading a class type it is parsed as loadvmtaddrn,
  462. typeinfo only needs the type so we remove the loadvmtaddrn }
  463. if p1.nodetype=loadvmtaddrn then
  464. begin
  465. p2:=tloadvmtaddrnode(p1).left;
  466. tloadvmtaddrnode(p1).left:=nil;
  467. p1.free;
  468. p1:=p2;
  469. end;
  470. if p1.nodetype=typen then
  471. ttypenode(p1).allowed:=true
  472. else
  473. begin
  474. p1.destroy;
  475. p1:=cerrornode.create;
  476. Message(parser_e_illegal_parameter_list);
  477. end;
  478. consume(_RKLAMMER);
  479. p2:=geninlinenode(in_typeinfo_x,false,p1);
  480. statement_syssym:=p2;
  481. end;
  482. in_assigned_x :
  483. begin
  484. err:=false;
  485. consume(_LKLAMMER);
  486. in_args:=true;
  487. p1:=comp_expr(true);
  488. { When reading a class type it is parsed as loadvmtaddrn,
  489. typeinfo only needs the type so we remove the loadvmtaddrn }
  490. if p1.nodetype=loadvmtaddrn then
  491. begin
  492. p2:=tloadvmtaddrnode(p1).left;
  493. tloadvmtaddrnode(p1).left:=nil;
  494. p1.free;
  495. p1:=p2;
  496. end;
  497. if not codegenerror then
  498. begin
  499. case p1.resulttype.def.deftype of
  500. procdef, { procvar }
  501. pointerdef,
  502. procvardef,
  503. classrefdef : ;
  504. objectdef :
  505. if not is_class_or_interface(p1.resulttype.def) then
  506. begin
  507. Message(parser_e_illegal_parameter_list);
  508. err:=true;
  509. end;
  510. arraydef :
  511. if not is_dynamic_array(p1.resulttype.def) then
  512. begin
  513. Message(parser_e_illegal_parameter_list);
  514. err:=true;
  515. end;
  516. else
  517. begin
  518. Message(parser_e_illegal_parameter_list);
  519. err:=true;
  520. end;
  521. end;
  522. end
  523. else
  524. err:=true;
  525. if not err then
  526. begin
  527. p2:=ccallparanode.create(p1,nil);
  528. p2:=geninlinenode(in_assigned_x,false,p2);
  529. end
  530. else
  531. begin
  532. p1.free;
  533. p2:=cerrornode.create;
  534. end;
  535. consume(_RKLAMMER);
  536. statement_syssym:=p2;
  537. end;
  538. in_addr_x :
  539. begin
  540. consume(_LKLAMMER);
  541. in_args:=true;
  542. p1:=comp_expr(true);
  543. p1:=caddrnode.create(p1);
  544. if cs_typed_addresses in aktlocalswitches then
  545. include(p1.flags,nf_typedaddr);
  546. consume(_RKLAMMER);
  547. statement_syssym:=p1;
  548. end;
  549. in_ofs_x :
  550. begin
  551. consume(_LKLAMMER);
  552. in_args:=true;
  553. p1:=comp_expr(true);
  554. p1:=caddrnode.create(p1);
  555. do_resulttypepass(p1);
  556. { Ofs() returns a cardinal/qword, not a pointer }
  557. p1.resulttype:=uinttype;
  558. consume(_RKLAMMER);
  559. statement_syssym:=p1;
  560. end;
  561. in_seg_x :
  562. begin
  563. consume(_LKLAMMER);
  564. in_args:=true;
  565. p1:=comp_expr(true);
  566. p1:=geninlinenode(in_seg_x,false,p1);
  567. consume(_RKLAMMER);
  568. statement_syssym:=p1;
  569. end;
  570. in_high_x,
  571. in_low_x :
  572. begin
  573. consume(_LKLAMMER);
  574. in_args:=true;
  575. p1:=comp_expr(true);
  576. p2:=geninlinenode(l,false,p1);
  577. consume(_RKLAMMER);
  578. statement_syssym:=p2;
  579. end;
  580. in_succ_x,
  581. in_pred_x :
  582. begin
  583. consume(_LKLAMMER);
  584. in_args:=true;
  585. p1:=comp_expr(true);
  586. p2:=geninlinenode(l,false,p1);
  587. consume(_RKLAMMER);
  588. statement_syssym:=p2;
  589. end;
  590. in_inc_x,
  591. in_dec_x :
  592. begin
  593. consume(_LKLAMMER);
  594. in_args:=true;
  595. p1:=comp_expr(true);
  596. if try_to_consume(_COMMA) then
  597. p2:=ccallparanode.create(comp_expr(true),nil)
  598. else
  599. p2:=nil;
  600. p2:=ccallparanode.create(p1,p2);
  601. statement_syssym:=geninlinenode(l,false,p2);
  602. consume(_RKLAMMER);
  603. end;
  604. in_initialize_x:
  605. begin
  606. statement_syssym:=inline_initialize;
  607. end;
  608. in_finalize_x:
  609. begin
  610. statement_syssym:=inline_finalize;
  611. end;
  612. in_copy_x:
  613. begin
  614. statement_syssym:=inline_copy;
  615. end;
  616. in_concat_x :
  617. begin
  618. consume(_LKLAMMER);
  619. in_args:=true;
  620. p2:=nil;
  621. repeat
  622. p1:=comp_expr(true);
  623. set_varstate(p1,vs_used,true);
  624. if not((p1.resulttype.def.deftype=stringdef) or
  625. ((p1.resulttype.def.deftype=orddef) and
  626. (torddef(p1.resulttype.def).typ=uchar))) then
  627. Message(parser_e_illegal_parameter_list);
  628. if p2<>nil then
  629. p2:=caddnode.create(addn,p2,p1)
  630. else
  631. p2:=p1;
  632. until not try_to_consume(_COMMA);
  633. consume(_RKLAMMER);
  634. statement_syssym:=p2;
  635. end;
  636. in_read_x,
  637. in_readln_x :
  638. begin
  639. if try_to_consume(_LKLAMMER) then
  640. begin
  641. paras:=parse_paras(false,false);
  642. consume(_RKLAMMER);
  643. end
  644. else
  645. paras:=nil;
  646. p1:=geninlinenode(l,false,paras);
  647. statement_syssym := p1;
  648. end;
  649. in_setlength_x:
  650. begin
  651. statement_syssym := inline_setlength;
  652. end;
  653. in_length_x:
  654. begin
  655. consume(_LKLAMMER);
  656. in_args:=true;
  657. p1:=comp_expr(true);
  658. p2:=geninlinenode(l,false,p1);
  659. consume(_RKLAMMER);
  660. statement_syssym:=p2;
  661. end;
  662. in_write_x,
  663. in_writeln_x :
  664. begin
  665. if try_to_consume(_LKLAMMER) then
  666. begin
  667. paras:=parse_paras(true,false);
  668. consume(_RKLAMMER);
  669. end
  670. else
  671. paras:=nil;
  672. p1 := geninlinenode(l,false,paras);
  673. statement_syssym := p1;
  674. end;
  675. in_str_x_string :
  676. begin
  677. consume(_LKLAMMER);
  678. paras:=parse_paras(true,false);
  679. consume(_RKLAMMER);
  680. p1 := geninlinenode(l,false,paras);
  681. statement_syssym := p1;
  682. end;
  683. in_val_x:
  684. Begin
  685. consume(_LKLAMMER);
  686. in_args := true;
  687. p1:= ccallparanode.create(comp_expr(true), nil);
  688. consume(_COMMA);
  689. p2 := ccallparanode.create(comp_expr(true),p1);
  690. if try_to_consume(_COMMA) then
  691. p2 := ccallparanode.create(comp_expr(true),p2);
  692. consume(_RKLAMMER);
  693. p2 := geninlinenode(l,false,p2);
  694. statement_syssym := p2;
  695. End;
  696. in_include_x_y,
  697. in_exclude_x_y :
  698. begin
  699. consume(_LKLAMMER);
  700. in_args:=true;
  701. p1:=comp_expr(true);
  702. consume(_COMMA);
  703. p2:=comp_expr(true);
  704. statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
  705. consume(_RKLAMMER);
  706. end;
  707. in_assert_x_y :
  708. begin
  709. consume(_LKLAMMER);
  710. in_args:=true;
  711. p1:=comp_expr(true);
  712. if try_to_consume(_COMMA) then
  713. p2:=comp_expr(true)
  714. else
  715. begin
  716. { then insert an empty string }
  717. p2:=cstringconstnode.createstr('',st_default);
  718. end;
  719. statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
  720. consume(_RKLAMMER);
  721. end;
  722. else
  723. internalerror(15);
  724. end;
  725. in_args:=prev_in_args;
  726. end;
  727. function maybe_load_methodpointer(st:tsymtable;var p1:tnode):boolean;
  728. begin
  729. maybe_load_methodpointer:=false;
  730. if not assigned(p1) then
  731. begin
  732. case st.symtabletype of
  733. withsymtable :
  734. begin
  735. if (st.defowner.deftype=objectdef) then
  736. p1:=tnode(twithsymtable(st).withrefnode).getcopy;
  737. end;
  738. objectsymtable :
  739. begin
  740. p1:=load_self_node;
  741. { We are calling a member }
  742. maybe_load_methodpointer:=true;
  743. end;
  744. end;
  745. end;
  746. end;
  747. { reads the parameter for a subroutine call }
  748. procedure do_proc_call(sym:tsym;st:tsymtable;obj:tobjectdef;getaddr:boolean;var again : boolean;var p1:tnode;callflags:tcallnodeflags);
  749. var
  750. membercall,
  751. prevafterassn : boolean;
  752. i : integer;
  753. para,p2 : tnode;
  754. currpara : tparavarsym;
  755. aprocdef : tprocdef;
  756. begin
  757. prevafterassn:=afterassignment;
  758. afterassignment:=false;
  759. membercall:=false;
  760. aprocdef:=nil;
  761. { when it is a call to a member we need to load the
  762. methodpointer first }
  763. membercall:=maybe_load_methodpointer(st,p1);
  764. { When we are expecting a procvar we also need
  765. to get the address in some cases }
  766. if assigned(getprocvardef) then
  767. begin
  768. if (block_type=bt_const) or
  769. getaddr then
  770. begin
  771. aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
  772. getaddr:=true;
  773. end
  774. else
  775. if (m_tp_procvar in aktmodeswitches) then
  776. begin
  777. aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
  778. if assigned(aprocdef) then
  779. getaddr:=true;
  780. end;
  781. end;
  782. { only need to get the address of the procedure? }
  783. if getaddr then
  784. begin
  785. { Retrieve info which procvar to call. For tp_procvar the
  786. aprocdef is already loaded above so we can reuse it }
  787. if not assigned(aprocdef) and
  788. assigned(getprocvardef) then
  789. aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
  790. { generate a methodcallnode or proccallnode }
  791. { we shouldn't convert things like @tcollection.load }
  792. p2:=cloadnode.create_procvar(sym,aprocdef,st);
  793. if assigned(p1) then
  794. begin
  795. if (p1.nodetype<>typen) then
  796. tloadnode(p2).set_mp(p1)
  797. else
  798. p1.free;
  799. end;
  800. p1:=p2;
  801. { no postfix operators }
  802. again:=false;
  803. end
  804. else
  805. begin
  806. para:=nil;
  807. if anon_inherited then
  808. begin
  809. if not assigned(current_procinfo) then
  810. internalerror(200305054);
  811. for i:=0 to current_procinfo.procdef.paras.count-1 do
  812. begin
  813. currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
  814. if not(vo_is_hidden_para in currpara.varoptions) then
  815. para:=ccallparanode.create(cloadnode.create(currpara,currpara.owner),para);
  816. end;
  817. end
  818. else
  819. begin
  820. if try_to_consume(_LKLAMMER) then
  821. begin
  822. para:=parse_paras(false,false);
  823. consume(_RKLAMMER);
  824. end;
  825. end;
  826. { indicate if this call was generated by a member and
  827. no explicit self is used, this is needed to determine
  828. how to handle a destructor call (PFV) }
  829. if membercall then
  830. include(callflags,cnf_member_call);
  831. if assigned(obj) then
  832. begin
  833. if (st.symtabletype<>objectsymtable) then
  834. internalerror(200310031);
  835. p1:=ccallnode.create(para,tprocsym(sym),obj.symtable,p1,callflags);
  836. end
  837. else
  838. p1:=ccallnode.create(para,tprocsym(sym),st,p1,callflags);
  839. end;
  840. afterassignment:=prevafterassn;
  841. end;
  842. procedure handle_procvar(pv : tprocvardef;var p2 : tnode);
  843. var
  844. hp,hp2 : tnode;
  845. hpp : ^tnode;
  846. currprocdef : tprocdef;
  847. begin
  848. if not assigned(pv) then
  849. internalerror(200301121);
  850. if (m_tp_procvar in aktmodeswitches) then
  851. begin
  852. hp:=p2;
  853. hpp:=@p2;
  854. while assigned(hp) and
  855. (hp.nodetype=typeconvn) do
  856. begin
  857. hp:=ttypeconvnode(hp).left;
  858. { save orignal address of the old tree so we can replace the node }
  859. hpp:=@hp;
  860. end;
  861. if (hp.nodetype=calln) and
  862. { a procvar can't have parameters! }
  863. not assigned(tcallnode(hp).left) then
  864. begin
  865. currprocdef:=tcallnode(hp).symtableprocentry.search_procdef_byprocvardef(pv);
  866. if assigned(currprocdef) then
  867. begin
  868. hp2:=cloadnode.create_procvar(tprocsym(tcallnode(hp).symtableprocentry),currprocdef,tcallnode(hp).symtableproc);
  869. if (po_methodpointer in pv.procoptions) then
  870. tloadnode(hp2).set_mp(tnode(tcallnode(hp).methodpointer).getcopy);
  871. hp.destroy;
  872. { replace the old callnode with the new loadnode }
  873. hpp^:=hp2;
  874. end;
  875. end;
  876. end;
  877. end;
  878. { the following procedure handles the access to a property symbol }
  879. procedure handle_propertysym(sym : tsym;st : tsymtable;var p1 : tnode);
  880. var
  881. paras : tnode;
  882. p2 : tnode;
  883. membercall : boolean;
  884. callflags : tcallnodeflags;
  885. begin
  886. paras:=nil;
  887. { property parameters? read them only if the property really }
  888. { has parameters }
  889. if (ppo_hasparameters in tpropertysym(sym).propoptions) then
  890. begin
  891. if try_to_consume(_LECKKLAMMER) then
  892. begin
  893. paras:=parse_paras(false,true);
  894. consume(_RECKKLAMMER);
  895. end;
  896. end;
  897. { indexed property }
  898. if (ppo_indexed in tpropertysym(sym).propoptions) then
  899. begin
  900. p2:=cordconstnode.create(tpropertysym(sym).index,tpropertysym(sym).indextype,true);
  901. paras:=ccallparanode.create(p2,paras);
  902. end;
  903. { we need only a write property if a := follows }
  904. { if not(afterassignment) and not(in_args) then }
  905. if token=_ASSIGNMENT then
  906. begin
  907. { write property: }
  908. if not tpropertysym(sym).writeaccess.empty then
  909. begin
  910. case tpropertysym(sym).writeaccess.firstsym^.sym.typ of
  911. procsym :
  912. begin
  913. callflags:=[];
  914. { generate the method call }
  915. membercall:=maybe_load_methodpointer(st,p1);
  916. if membercall then
  917. include(callflags,cnf_member_call);
  918. p1:=ccallnode.create(paras,tprocsym(tpropertysym(sym).writeaccess.firstsym^.sym),st,p1,callflags);
  919. paras:=nil;
  920. consume(_ASSIGNMENT);
  921. { read the expression }
  922. if tpropertysym(sym).proptype.def.deftype=procvardef then
  923. getprocvardef:=tprocvardef(tpropertysym(sym).proptype.def);
  924. p2:=comp_expr(true);
  925. if assigned(getprocvardef) then
  926. handle_procvar(getprocvardef,p2);
  927. tcallnode(p1).left:=ccallparanode.create(p2,tcallnode(p1).left);
  928. { mark as property, both the tcallnode and the real call block }
  929. include(p1.flags,nf_isproperty);
  930. getprocvardef:=nil;
  931. end;
  932. fieldvarsym :
  933. begin
  934. { generate access code }
  935. symlist_to_node(p1,st,tpropertysym(sym).writeaccess);
  936. include(p1.flags,nf_isproperty);
  937. consume(_ASSIGNMENT);
  938. { read the expression }
  939. p2:=comp_expr(true);
  940. p1:=cassignmentnode.create(p1,p2);
  941. end
  942. else
  943. begin
  944. p1:=cerrornode.create;
  945. Message(parser_e_no_procedure_to_access_property);
  946. end;
  947. end;
  948. end
  949. else
  950. begin
  951. p1:=cerrornode.create;
  952. Message(parser_e_no_procedure_to_access_property);
  953. end;
  954. end
  955. else
  956. begin
  957. { read property: }
  958. if not tpropertysym(sym).readaccess.empty then
  959. begin
  960. case tpropertysym(sym).readaccess.firstsym^.sym.typ of
  961. fieldvarsym :
  962. begin
  963. { generate access code }
  964. symlist_to_node(p1,st,tpropertysym(sym).readaccess);
  965. include(p1.flags,nf_isproperty);
  966. end;
  967. procsym :
  968. begin
  969. callflags:=[];
  970. { generate the method call }
  971. membercall:=maybe_load_methodpointer(st,p1);
  972. if membercall then
  973. include(callflags,cnf_member_call);
  974. p1:=ccallnode.create(paras,tprocsym(tpropertysym(sym).readaccess.firstsym^.sym),st,p1,callflags);
  975. paras:=nil;
  976. include(p1.flags,nf_isproperty);
  977. end
  978. else
  979. begin
  980. p1:=cerrornode.create;
  981. Message(type_e_mismatch);
  982. end;
  983. end;
  984. end
  985. else
  986. begin
  987. { error, no function to read property }
  988. p1:=cerrornode.create;
  989. Message(parser_e_no_procedure_to_access_property);
  990. end;
  991. end;
  992. { release paras if not used }
  993. if assigned(paras) then
  994. paras.free;
  995. end;
  996. { the ID token has to be consumed before calling this function }
  997. procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callflags:tcallnodeflags);
  998. var
  999. static_name : string;
  1000. isclassref : boolean;
  1001. srsymtable : tsymtable;
  1002. begin
  1003. if sym=nil then
  1004. begin
  1005. { pattern is still valid unless
  1006. there is another ID just after the ID of sym }
  1007. Message1(sym_e_id_no_member,orgpattern);
  1008. p1.free;
  1009. p1:=cerrornode.create;
  1010. { try to clean up }
  1011. again:=false;
  1012. end
  1013. else
  1014. begin
  1015. if assigned(p1) then
  1016. begin
  1017. if not assigned(p1.resulttype.def) then
  1018. do_resulttypepass(p1);
  1019. isclassref:=(p1.resulttype.def.deftype=classrefdef);
  1020. end
  1021. else
  1022. isclassref:=false;
  1023. { we assume, that only procsyms and varsyms are in an object }
  1024. { symbol table, for classes, properties are allowed }
  1025. case sym.typ of
  1026. procsym:
  1027. begin
  1028. do_proc_call(sym,sym.owner,classh,
  1029. (getaddr and not(token in [_CARET,_POINT])),
  1030. again,p1,callflags);
  1031. { we need to know which procedure is called }
  1032. do_resulttypepass(p1);
  1033. { calling using classref? }
  1034. if isclassref and
  1035. (p1.nodetype=calln) and
  1036. assigned(tcallnode(p1).procdefinition) and
  1037. not(po_classmethod in tcallnode(p1).procdefinition.procoptions) and
  1038. not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) then
  1039. Message(parser_e_only_class_methods_via_class_ref);
  1040. end;
  1041. fieldvarsym:
  1042. begin
  1043. if (sp_static in sym.symoptions) then
  1044. begin
  1045. static_name:=lower(sym.owner.name^)+'_'+sym.name;
  1046. searchsym(static_name,sym,srsymtable);
  1047. check_hints(sym);
  1048. p1.free;
  1049. p1:=cloadnode.create(sym,srsymtable);
  1050. end
  1051. else
  1052. begin
  1053. if isclassref then
  1054. Message(parser_e_only_class_methods_via_class_ref);
  1055. p1:=csubscriptnode.create(sym,p1);
  1056. end;
  1057. end;
  1058. propertysym:
  1059. begin
  1060. if isclassref then
  1061. Message(parser_e_only_class_methods_via_class_ref);
  1062. handle_propertysym(sym,sym.owner,p1);
  1063. end;
  1064. else internalerror(16);
  1065. end;
  1066. end;
  1067. end;
  1068. {****************************************************************************
  1069. Factor
  1070. ****************************************************************************}
  1071. {$ifdef fpc}
  1072. {$maxfpuregisters 0}
  1073. {$endif fpc}
  1074. function factor(getaddr : boolean) : tnode;
  1075. {---------------------------------------------
  1076. Factor_read_id
  1077. ---------------------------------------------}
  1078. procedure factor_read_id(var p1:tnode;var again:boolean);
  1079. var
  1080. pc : pchar;
  1081. len : longint;
  1082. srsym : tsym;
  1083. possible_error : boolean;
  1084. srsymtable : tsymtable;
  1085. storesymtablestack : tsymtable;
  1086. htype : ttype;
  1087. static_name : string;
  1088. begin
  1089. { allow post fix operators }
  1090. again:=true;
  1091. consume_sym(srsym,srsymtable);
  1092. { Access to funcret or need to call the function? }
  1093. if (srsym.typ in [absolutevarsym,localvarsym,paravarsym]) and
  1094. (vo_is_funcret in tabstractvarsym(srsym).varoptions) and
  1095. (
  1096. (token=_LKLAMMER) or
  1097. (not(m_fpc in aktmodeswitches) and
  1098. (afterassignment or in_args) and
  1099. not(vo_is_result in tabstractvarsym(srsym).varoptions))
  1100. ) then
  1101. begin
  1102. storesymtablestack:=symtablestack;
  1103. symtablestack:=srsym.owner.next;
  1104. searchsym(srsym.name,srsym,srsymtable);
  1105. if not assigned(srsym) then
  1106. srsym:=generrorsym;
  1107. if (srsym.typ<>procsym) then
  1108. Message(parser_e_illegal_expression);
  1109. symtablestack:=storesymtablestack;
  1110. end;
  1111. begin
  1112. case srsym.typ of
  1113. absolutevarsym :
  1114. begin
  1115. if (tabsolutevarsym(srsym).abstyp=tovar) then
  1116. begin
  1117. p1:=nil;
  1118. symlist_to_node(p1,nil,tabsolutevarsym(srsym).ref);
  1119. p1:=ctypeconvnode.create(p1,tabsolutevarsym(srsym).vartype);
  1120. include(p1.flags,nf_absolute);
  1121. end
  1122. else
  1123. p1:=cloadnode.create(srsym,srsymtable);
  1124. end;
  1125. globalvarsym,
  1126. localvarsym,
  1127. paravarsym,
  1128. fieldvarsym :
  1129. begin
  1130. if (sp_static in srsym.symoptions) then
  1131. begin
  1132. static_name:=lower(srsym.owner.name^)+'_'+srsym.name;
  1133. searchsym(static_name,srsym,srsymtable);
  1134. check_hints(srsym);
  1135. end
  1136. else
  1137. begin
  1138. { are we in a class method, we check here the
  1139. srsymtable, because a field in another object
  1140. also has objectsymtable. And withsymtable is
  1141. not possible for self in class methods (PFV) }
  1142. if (srsymtable.symtabletype=objectsymtable) and
  1143. assigned(current_procinfo) and
  1144. (po_classmethod in current_procinfo.procdef.procoptions) then
  1145. Message(parser_e_only_class_methods);
  1146. end;
  1147. case srsymtable.symtabletype of
  1148. objectsymtable :
  1149. begin
  1150. p1:=csubscriptnode.create(srsym,load_self_node);
  1151. node_tree_set_filepos(p1,aktfilepos);
  1152. end;
  1153. withsymtable :
  1154. begin
  1155. p1:=csubscriptnode.create(srsym,tnode(twithsymtable(srsymtable).withrefnode).getcopy);
  1156. node_tree_set_filepos(p1,aktfilepos);
  1157. end;
  1158. else
  1159. p1:=cloadnode.create(srsym,srsymtable);
  1160. end;
  1161. end;
  1162. typedconstsym :
  1163. begin
  1164. p1:=cloadnode.create(srsym,srsymtable);
  1165. end;
  1166. syssym :
  1167. begin
  1168. p1:=statement_syssym(tsyssym(srsym).number);
  1169. end;
  1170. typesym :
  1171. begin
  1172. htype.setsym(srsym);
  1173. if not assigned(htype.def) then
  1174. begin
  1175. again:=false;
  1176. end
  1177. else
  1178. begin
  1179. { We need to know if this unit uses Variants }
  1180. if (htype.def=cvarianttype.def) and
  1181. not(cs_compilesystem in aktmoduleswitches) then
  1182. current_module.flags:=current_module.flags or uf_uses_variants;
  1183. if try_to_consume(_LKLAMMER) then
  1184. begin
  1185. p1:=comp_expr(true);
  1186. consume(_RKLAMMER);
  1187. p1:=ctypeconvnode.create_explicit(p1,htype);
  1188. end
  1189. else { not LKLAMMER }
  1190. if (token=_POINT) and
  1191. is_object(htype.def) then
  1192. begin
  1193. consume(_POINT);
  1194. if assigned(current_procinfo) and
  1195. assigned(current_procinfo.procdef._class) and
  1196. not(getaddr) then
  1197. begin
  1198. if current_procinfo.procdef._class.is_related(tobjectdef(htype.def)) then
  1199. begin
  1200. p1:=ctypenode.create(htype);
  1201. { search also in inherited methods }
  1202. srsym:=searchsym_in_class(tobjectdef(htype.def),pattern);
  1203. check_hints(srsym);
  1204. consume(_ID);
  1205. do_member_read(tobjectdef(htype.def),false,srsym,p1,again,[]);
  1206. end
  1207. else
  1208. begin
  1209. Message(parser_e_no_super_class);
  1210. again:=false;
  1211. end;
  1212. end
  1213. else
  1214. begin
  1215. { allows @TObject.Load }
  1216. { also allows static methods and variables }
  1217. p1:=ctypenode.create(htype);
  1218. { TP allows also @TMenu.Load if Load is only }
  1219. { defined in an anchestor class }
  1220. srsym:=search_class_member(tobjectdef(htype.def),pattern);
  1221. check_hints(srsym);
  1222. if not assigned(srsym) then
  1223. Message1(sym_e_id_no_member,orgpattern)
  1224. else if not(getaddr) and not(sp_static in srsym.symoptions) then
  1225. Message(sym_e_only_static_in_static)
  1226. else
  1227. begin
  1228. consume(_ID);
  1229. do_member_read(tobjectdef(htype.def),getaddr,srsym,p1,again,[]);
  1230. end;
  1231. end;
  1232. end
  1233. else
  1234. begin
  1235. { class reference ? }
  1236. if is_class(htype.def) then
  1237. begin
  1238. if getaddr and (token=_POINT) then
  1239. begin
  1240. consume(_POINT);
  1241. { allows @Object.Method }
  1242. { also allows static methods and variables }
  1243. p1:=ctypenode.create(htype);
  1244. { TP allows also @TMenu.Load if Load is only }
  1245. { defined in an anchestor class }
  1246. srsym:=search_class_member(tobjectdef(htype.def),pattern);
  1247. check_hints(srsym);
  1248. if not assigned(srsym) then
  1249. Message1(sym_e_id_no_member,orgpattern)
  1250. else
  1251. begin
  1252. consume(_ID);
  1253. do_member_read(tobjectdef(htype.def),getaddr,srsym,p1,again,[]);
  1254. end;
  1255. end
  1256. else
  1257. begin
  1258. p1:=ctypenode.create(htype);
  1259. { For a type block we simply return only
  1260. the type. For all other blocks we return
  1261. a loadvmt node }
  1262. if (block_type<>bt_type) then
  1263. p1:=cloadvmtaddrnode.create(p1);
  1264. end;
  1265. end
  1266. else
  1267. p1:=ctypenode.create(htype);
  1268. end;
  1269. end;
  1270. end;
  1271. enumsym :
  1272. begin
  1273. p1:=genenumnode(tenumsym(srsym));
  1274. end;
  1275. constsym :
  1276. begin
  1277. case tconstsym(srsym).consttyp of
  1278. constord :
  1279. begin
  1280. if tconstsym(srsym).consttype.def=nil then
  1281. internalerror(200403232);
  1282. p1:=cordconstnode.create(tconstsym(srsym).value.valueord,tconstsym(srsym).consttype,true);
  1283. end;
  1284. conststring :
  1285. begin
  1286. len:=tconstsym(srsym).value.len;
  1287. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  1288. len:=255;
  1289. getmem(pc,len+1);
  1290. move(pchar(tconstsym(srsym).value.valueptr)^,pc^,len);
  1291. pc[len]:=#0;
  1292. p1:=cstringconstnode.createpchar(pc,len);
  1293. end;
  1294. constreal :
  1295. p1:=crealconstnode.create(pbestreal(tconstsym(srsym).value.valueptr)^,pbestrealtype^);
  1296. constset :
  1297. p1:=csetconstnode.create(pconstset(tconstsym(srsym).value.valueptr),tconstsym(srsym).consttype);
  1298. constpointer :
  1299. p1:=cpointerconstnode.create(tconstsym(srsym).value.valueordptr,tconstsym(srsym).consttype);
  1300. constnil :
  1301. p1:=cnilnode.create;
  1302. constresourcestring:
  1303. begin
  1304. p1:=cloadnode.create(srsym,srsymtable);
  1305. do_resulttypepass(p1);
  1306. {$ifdef ansistring_bits}
  1307. case aktansistring_bits of
  1308. sb_16:
  1309. p1.resulttype:=cansistringtype16;
  1310. sb_32:
  1311. p1.resulttype:=cansistringtype32;
  1312. sb_64:
  1313. p1.resulttype:=cansistringtype64;
  1314. end;
  1315. {$else}
  1316. p1.resulttype:=cansistringtype;
  1317. {$endif}
  1318. end;
  1319. constguid :
  1320. p1:=cguidconstnode.create(pguid(tconstsym(srsym).value.valueptr)^);
  1321. end;
  1322. end;
  1323. procsym :
  1324. begin
  1325. { are we in a class method ? }
  1326. possible_error:=(srsymtable.symtabletype<>withsymtable) and
  1327. (srsym.owner.symtabletype=objectsymtable) and
  1328. not(is_interface(tdef(srsym.owner.defowner))) and
  1329. assigned(current_procinfo) and
  1330. (po_classmethod in current_procinfo.procdef.procoptions);
  1331. do_proc_call(srsym,srsymtable,nil,
  1332. (getaddr and not(token in [_CARET,_POINT])),
  1333. again,p1,[]);
  1334. { we need to know which procedure is called }
  1335. if possible_error then
  1336. begin
  1337. do_resulttypepass(p1);
  1338. if (p1.nodetype=calln) and
  1339. assigned(tcallnode(p1).procdefinition) and
  1340. not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
  1341. not(po_classmethod in tcallnode(p1).procdefinition.procoptions) then
  1342. Message(parser_e_only_class_methods);
  1343. end;
  1344. end;
  1345. propertysym :
  1346. begin
  1347. { access to property in a method }
  1348. { are we in a class method ? }
  1349. if (srsymtable.symtabletype=objectsymtable) and
  1350. assigned(current_procinfo) and
  1351. (po_classmethod in current_procinfo.procdef.procoptions) then
  1352. Message(parser_e_only_class_methods);
  1353. { no method pointer }
  1354. p1:=nil;
  1355. handle_propertysym(srsym,srsymtable,p1);
  1356. end;
  1357. labelsym :
  1358. begin
  1359. { Support @label }
  1360. if getaddr then
  1361. p1:=cloadnode.create(srsym,srsym.owner)
  1362. else
  1363. begin
  1364. consume(_COLON);
  1365. if tlabelsym(srsym).defined then
  1366. Message(sym_e_label_already_defined);
  1367. tlabelsym(srsym).defined:=true;
  1368. p1:=clabelnode.create(tlabelsym(srsym),nil);
  1369. end;
  1370. end;
  1371. errorsym :
  1372. begin
  1373. p1:=cerrornode.create;
  1374. if try_to_consume(_LKLAMMER) then
  1375. begin
  1376. parse_paras(false,false);
  1377. consume(_RKLAMMER);
  1378. end;
  1379. end;
  1380. else
  1381. begin
  1382. p1:=cerrornode.create;
  1383. Message(parser_e_illegal_expression);
  1384. end;
  1385. end; { end case }
  1386. end;
  1387. end;
  1388. {---------------------------------------------
  1389. Factor_Read_Set
  1390. ---------------------------------------------}
  1391. { Read a set between [] }
  1392. function factor_read_set:tnode;
  1393. var
  1394. p1,p2 : tnode;
  1395. lastp,
  1396. buildp : tarrayconstructornode;
  1397. begin
  1398. buildp:=nil;
  1399. { be sure that a least one arrayconstructn is used, also for an
  1400. empty [] }
  1401. if token=_RECKKLAMMER then
  1402. buildp:=carrayconstructornode.create(nil,buildp)
  1403. else
  1404. repeat
  1405. p1:=comp_expr(true);
  1406. if try_to_consume(_POINTPOINT) then
  1407. begin
  1408. p2:=comp_expr(true);
  1409. p1:=carrayconstructorrangenode.create(p1,p2);
  1410. end;
  1411. { insert at the end of the tree, to get the correct order }
  1412. if not assigned(buildp) then
  1413. begin
  1414. buildp:=carrayconstructornode.create(p1,nil);
  1415. lastp:=buildp;
  1416. end
  1417. else
  1418. begin
  1419. lastp.right:=carrayconstructornode.create(p1,nil);
  1420. lastp:=tarrayconstructornode(lastp.right);
  1421. end;
  1422. { there could be more elements }
  1423. until not try_to_consume(_COMMA);
  1424. factor_read_set:=buildp;
  1425. end;
  1426. {---------------------------------------------
  1427. PostFixOperators
  1428. ---------------------------------------------}
  1429. procedure postfixoperators(var p1:tnode;var again:boolean);
  1430. { tries to avoid syntax errors after invalid qualifiers }
  1431. procedure recoverconsume_postfixops;
  1432. begin
  1433. repeat
  1434. if not try_to_consume(_CARET) then
  1435. if try_to_consume(_POINT) then
  1436. try_to_consume(_ID)
  1437. else if try_to_consume(_LECKKLAMMER) then
  1438. begin
  1439. repeat
  1440. comp_expr(true);
  1441. until not try_to_consume(_COMMA);
  1442. consume(_RECKKLAMMER);
  1443. end
  1444. else
  1445. break;
  1446. until false;
  1447. end;
  1448. var
  1449. store_static : boolean;
  1450. protsym : tpropertysym;
  1451. p2,p3 : tnode;
  1452. hsym : tsym;
  1453. classh : tobjectdef;
  1454. begin
  1455. again:=true;
  1456. while again do
  1457. begin
  1458. { we need the resulttype }
  1459. do_resulttypepass(p1);
  1460. if codegenerror then
  1461. begin
  1462. recoverconsume_postfixops;
  1463. exit;
  1464. end;
  1465. { handle token }
  1466. case token of
  1467. _CARET:
  1468. begin
  1469. consume(_CARET);
  1470. if (p1.resulttype.def.deftype<>pointerdef) then
  1471. begin
  1472. { ^ as binary operator is a problem!!!! (FK) }
  1473. again:=false;
  1474. Message(parser_e_invalid_qualifier);
  1475. recoverconsume_postfixops;
  1476. p1.destroy;
  1477. p1:=cerrornode.create;
  1478. end
  1479. else
  1480. begin
  1481. p1:=cderefnode.create(p1);
  1482. end;
  1483. end;
  1484. _LECKKLAMMER:
  1485. begin
  1486. if is_class_or_interface(p1.resulttype.def) then
  1487. begin
  1488. { default property }
  1489. protsym:=search_default_property(tobjectdef(p1.resulttype.def));
  1490. if not(assigned(protsym)) then
  1491. begin
  1492. p1.destroy;
  1493. p1:=cerrornode.create;
  1494. again:=false;
  1495. message(parser_e_no_default_property_available);
  1496. end
  1497. else
  1498. begin
  1499. { The property symbol is referenced indirect }
  1500. inc(protsym.refs);
  1501. handle_propertysym(protsym,protsym.owner,p1);
  1502. end;
  1503. end
  1504. else
  1505. begin
  1506. consume(_LECKKLAMMER);
  1507. repeat
  1508. case p1.resulttype.def.deftype of
  1509. pointerdef:
  1510. begin
  1511. { support delphi autoderef }
  1512. if (tpointerdef(p1.resulttype.def).pointertype.def.deftype=arraydef) and
  1513. (m_autoderef in aktmodeswitches) then
  1514. begin
  1515. p1:=cderefnode.create(p1);
  1516. end;
  1517. p2:=comp_expr(true);
  1518. p1:=cvecnode.create(p1,p2);
  1519. end;
  1520. variantdef,
  1521. stringdef :
  1522. begin
  1523. p2:=comp_expr(true);
  1524. p1:=cvecnode.create(p1,p2);
  1525. end;
  1526. arraydef :
  1527. begin
  1528. p2:=comp_expr(true);
  1529. { support SEG:OFS for go32v2 Mem[] }
  1530. if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
  1531. (p1.nodetype=loadn) and
  1532. assigned(tloadnode(p1).symtableentry) and
  1533. assigned(tloadnode(p1).symtableentry.owner.name) and
  1534. (tloadnode(p1).symtableentry.owner.name^='SYSTEM') and
  1535. ((tloadnode(p1).symtableentry.name='MEM') or
  1536. (tloadnode(p1).symtableentry.name='MEMW') or
  1537. (tloadnode(p1).symtableentry.name='MEML')) then
  1538. begin
  1539. if try_to_consume(_COLON) then
  1540. begin
  1541. p3:=caddnode.create(muln,cordconstnode.create($10,s32inttype,false),p2);
  1542. p2:=comp_expr(true);
  1543. p2:=caddnode.create(addn,p2,p3);
  1544. p1:=cvecnode.create(p1,p2);
  1545. include(tvecnode(p1).flags,nf_memseg);
  1546. include(tvecnode(p1).flags,nf_memindex);
  1547. end
  1548. else
  1549. begin
  1550. p1:=cvecnode.create(p1,p2);
  1551. include(tvecnode(p1).flags,nf_memindex);
  1552. end;
  1553. end
  1554. else
  1555. p1:=cvecnode.create(p1,p2);
  1556. end;
  1557. else
  1558. begin
  1559. Message(parser_e_invalid_qualifier);
  1560. p1.destroy;
  1561. p1:=cerrornode.create;
  1562. comp_expr(true);
  1563. again:=false;
  1564. end;
  1565. end;
  1566. do_resulttypepass(p1);
  1567. until not try_to_consume(_COMMA);;
  1568. consume(_RECKKLAMMER);
  1569. end;
  1570. end;
  1571. _POINT :
  1572. begin
  1573. consume(_POINT);
  1574. if (p1.resulttype.def.deftype=pointerdef) and
  1575. (m_autoderef in aktmodeswitches) then
  1576. begin
  1577. p1:=cderefnode.create(p1);
  1578. do_resulttypepass(p1);
  1579. end;
  1580. case p1.resulttype.def.deftype of
  1581. recorddef:
  1582. begin
  1583. if token=_ID then
  1584. begin
  1585. hsym:=tsym(trecorddef(p1.resulttype.def).symtable.search(pattern));
  1586. check_hints(hsym);
  1587. if assigned(hsym) and
  1588. (hsym.typ=fieldvarsym) then
  1589. p1:=csubscriptnode.create(hsym,p1)
  1590. else
  1591. begin
  1592. Message1(sym_e_illegal_field,pattern);
  1593. p1.destroy;
  1594. p1:=cerrornode.create;
  1595. end;
  1596. end;
  1597. consume(_ID);
  1598. end;
  1599. variantdef:
  1600. begin
  1601. end;
  1602. classrefdef:
  1603. begin
  1604. if token=_ID then
  1605. begin
  1606. classh:=tobjectdef(tclassrefdef(p1.resulttype.def).pointertype.def);
  1607. hsym:=searchsym_in_class(classh,pattern);
  1608. check_hints(hsym);
  1609. if hsym=nil then
  1610. begin
  1611. Message1(sym_e_id_no_member,orgpattern);
  1612. p1.destroy;
  1613. p1:=cerrornode.create;
  1614. { try to clean up }
  1615. consume(_ID);
  1616. end
  1617. else
  1618. begin
  1619. consume(_ID);
  1620. do_member_read(classh,getaddr,hsym,p1,again,[]);
  1621. end;
  1622. end
  1623. else { Error }
  1624. Consume(_ID);
  1625. end;
  1626. objectdef:
  1627. begin
  1628. if token=_ID then
  1629. begin
  1630. store_static:=allow_only_static;
  1631. allow_only_static:=false;
  1632. classh:=tobjectdef(p1.resulttype.def);
  1633. hsym:=searchsym_in_class(classh,pattern);
  1634. check_hints(hsym);
  1635. allow_only_static:=store_static;
  1636. if hsym=nil then
  1637. begin
  1638. Message1(sym_e_id_no_member,orgpattern);
  1639. p1.destroy;
  1640. p1:=cerrornode.create;
  1641. { try to clean up }
  1642. consume(_ID);
  1643. end
  1644. else
  1645. begin
  1646. consume(_ID);
  1647. do_member_read(classh,getaddr,hsym,p1,again,[]);
  1648. end;
  1649. end
  1650. else { Error }
  1651. Consume(_ID);
  1652. end;
  1653. pointerdef:
  1654. begin
  1655. Message(parser_e_invalid_qualifier);
  1656. if tpointerdef(p1.resulttype.def).pointertype.def.deftype in [recorddef,objectdef,classrefdef] then
  1657. Message(parser_h_maybe_deref_caret_missing);
  1658. end;
  1659. else
  1660. begin
  1661. Message(parser_e_invalid_qualifier);
  1662. p1.destroy;
  1663. p1:=cerrornode.create;
  1664. { Error }
  1665. consume(_ID);
  1666. end;
  1667. end;
  1668. end;
  1669. else
  1670. begin
  1671. { is this a procedure variable ? }
  1672. if assigned(p1.resulttype.def) and
  1673. (p1.resulttype.def.deftype=procvardef) then
  1674. begin
  1675. if assigned(getprocvardef) and
  1676. equal_defs(p1.resulttype.def,getprocvardef) then
  1677. again:=false
  1678. else
  1679. begin
  1680. if try_to_consume(_LKLAMMER) then
  1681. begin
  1682. p2:=parse_paras(false,false);
  1683. consume(_RKLAMMER);
  1684. p1:=ccallnode.create_procvar(p2,p1);
  1685. { proc():= is never possible }
  1686. if token=_ASSIGNMENT then
  1687. begin
  1688. Message(parser_e_illegal_expression);
  1689. p1.free;
  1690. p1:=cerrornode.create;
  1691. again:=false;
  1692. end;
  1693. end
  1694. else
  1695. again:=false;
  1696. end;
  1697. end
  1698. else
  1699. again:=false;
  1700. end;
  1701. end;
  1702. end; { while again }
  1703. end;
  1704. {---------------------------------------------
  1705. Factor (Main)
  1706. ---------------------------------------------}
  1707. var
  1708. l : longint;
  1709. ic : int64;
  1710. qc : qword;
  1711. {$ifndef cpu64}
  1712. card : cardinal;
  1713. {$endif cpu64}
  1714. oldp1,
  1715. p1 : tnode;
  1716. code : integer;
  1717. again : boolean;
  1718. sym : tsym;
  1719. pd : tprocdef;
  1720. classh : tobjectdef;
  1721. d : bestreal;
  1722. hs,hsorg : string;
  1723. htype : ttype;
  1724. filepos : tfileposinfo;
  1725. {---------------------------------------------
  1726. Helpers
  1727. ---------------------------------------------}
  1728. procedure check_tokenpos;
  1729. begin
  1730. if (p1<>oldp1) then
  1731. begin
  1732. if assigned(p1) then
  1733. p1.fileinfo:=filepos;
  1734. oldp1:=p1;
  1735. filepos:=akttokenpos;
  1736. end;
  1737. end;
  1738. begin
  1739. oldp1:=nil;
  1740. p1:=nil;
  1741. filepos:=akttokenpos;
  1742. again:=false;
  1743. if token=_ID then
  1744. begin
  1745. again:=true;
  1746. { Handle references to self }
  1747. if (idtoken=_SELF) and
  1748. not(block_type in [bt_const,bt_type]) and
  1749. assigned(current_procinfo) and
  1750. assigned(current_procinfo.procdef._class) then
  1751. begin
  1752. p1:=load_self_node;
  1753. consume(_ID);
  1754. again:=true;
  1755. end
  1756. else
  1757. factor_read_id(p1,again);
  1758. if again then
  1759. begin
  1760. check_tokenpos;
  1761. { handle post fix operators }
  1762. postfixoperators(p1,again);
  1763. end;
  1764. end
  1765. else
  1766. case token of
  1767. _INHERITED :
  1768. begin
  1769. again:=true;
  1770. consume(_INHERITED);
  1771. if assigned(current_procinfo) and
  1772. assigned(current_procinfo.procdef._class) then
  1773. begin
  1774. classh:=current_procinfo.procdef._class.childof;
  1775. { if inherited; only then we need the method with
  1776. the same name }
  1777. if token in endtokens then
  1778. begin
  1779. hs:=current_procinfo.procdef.procsym.name;
  1780. hsorg:=current_procinfo.procdef.procsym.realname;
  1781. anon_inherited:=true;
  1782. { For message methods we need to search using the message
  1783. number or string }
  1784. pd:=tprocsym(current_procinfo.procdef.procsym).first_procdef;
  1785. if (po_msgint in pd.procoptions) then
  1786. sym:=searchsym_in_class_by_msgint(classh,pd.messageinf.i)
  1787. else
  1788. if (po_msgstr in pd.procoptions) then
  1789. sym:=searchsym_in_class_by_msgstr(classh,pd.messageinf.str)
  1790. else
  1791. sym:=searchsym_in_class(classh,hs);
  1792. end
  1793. else
  1794. begin
  1795. hs:=pattern;
  1796. hsorg:=orgpattern;
  1797. consume(_ID);
  1798. anon_inherited:=false;
  1799. sym:=searchsym_in_class(classh,hs);
  1800. end;
  1801. if assigned(sym) then
  1802. begin
  1803. check_hints(sym);
  1804. { load the procdef from the inherited class and
  1805. not from self }
  1806. if sym.typ=procsym then
  1807. begin
  1808. htype.setdef(classh);
  1809. if (po_classmethod in current_procinfo.procdef.procoptions) or
  1810. (po_staticmethod in current_procinfo.procdef.procoptions) then
  1811. htype.setdef(tclassrefdef.create(htype));
  1812. p1:=ctypenode.create(htype);
  1813. end;
  1814. do_member_read(classh,false,sym,p1,again,[cnf_inherited,cnf_anon_inherited]);
  1815. end
  1816. else
  1817. begin
  1818. if anon_inherited then
  1819. begin
  1820. { For message methods we need to call DefaultHandler }
  1821. if (po_msgint in pd.procoptions) or
  1822. (po_msgstr in pd.procoptions) then
  1823. begin
  1824. sym:=searchsym_in_class(classh,'DEFAULTHANDLER');
  1825. if not assigned(sym) or
  1826. (sym.typ<>procsym) then
  1827. internalerror(200303171);
  1828. p1:=nil;
  1829. do_proc_call(sym,sym.owner,classh,false,again,p1,[]);
  1830. end
  1831. else
  1832. begin
  1833. { we need to ignore the inherited; }
  1834. p1:=cnothingnode.create;
  1835. end;
  1836. end
  1837. else
  1838. begin
  1839. Message1(sym_e_id_no_member,hsorg);
  1840. p1:=cerrornode.create;
  1841. end;
  1842. again:=false;
  1843. end;
  1844. { turn auto inheriting off }
  1845. anon_inherited:=false;
  1846. end
  1847. else
  1848. begin
  1849. Message(parser_e_generic_methods_only_in_methods);
  1850. again:=false;
  1851. p1:=cerrornode.create;
  1852. end;
  1853. postfixoperators(p1,again);
  1854. end;
  1855. _INTCONST :
  1856. begin
  1857. {$ifdef cpu64}
  1858. { when already running under 64bit must read int64 constant, because reading
  1859. cardinal first will also succeed (code=0) for values > maxcardinal, because
  1860. range checking is off by default (PFV) }
  1861. val(pattern,ic,code);
  1862. if code=0 then
  1863. begin
  1864. consume(_INTCONST);
  1865. int_to_type(ic,htype);
  1866. p1:=cordconstnode.create(ic,htype,true);
  1867. end
  1868. else
  1869. begin
  1870. { try qword next }
  1871. val(pattern,qc,code);
  1872. if code=0 then
  1873. begin
  1874. consume(_INTCONST);
  1875. htype:=u64inttype;
  1876. p1:=cordconstnode.create(qc,htype,true);
  1877. end;
  1878. end;
  1879. {$else}
  1880. { try cardinal first }
  1881. val(pattern,card,code);
  1882. if code=0 then
  1883. begin
  1884. consume(_INTCONST);
  1885. int_to_type(card,htype);
  1886. p1:=cordconstnode.create(card,htype,true);
  1887. end
  1888. else
  1889. begin
  1890. { then longint }
  1891. val(pattern,l,code);
  1892. if code = 0 then
  1893. begin
  1894. consume(_INTCONST);
  1895. int_to_type(l,htype);
  1896. p1:=cordconstnode.create(l,htype,true);
  1897. end
  1898. else
  1899. begin
  1900. { then int64 }
  1901. val(pattern,ic,code);
  1902. if code=0 then
  1903. begin
  1904. consume(_INTCONST);
  1905. int_to_type(ic,htype);
  1906. p1:=cordconstnode.create(ic,htype,true);
  1907. end
  1908. else
  1909. begin
  1910. { try qword next }
  1911. val(pattern,qc,code);
  1912. if code=0 then
  1913. begin
  1914. consume(_INTCONST);
  1915. htype:=u64inttype;
  1916. p1:=cordconstnode.create(tconstexprint(qc),htype,true);
  1917. end;
  1918. end;
  1919. end;
  1920. end;
  1921. {$endif}
  1922. if code<>0 then
  1923. begin
  1924. { finally float }
  1925. val(pattern,d,code);
  1926. if code<>0 then
  1927. begin
  1928. Message(parser_e_invalid_integer);
  1929. consume(_INTCONST);
  1930. l:=1;
  1931. p1:=cordconstnode.create(l,sinttype,true);
  1932. end
  1933. else
  1934. begin
  1935. consume(_INTCONST);
  1936. p1:=crealconstnode.create(d,pbestrealtype^);
  1937. end;
  1938. end;
  1939. end;
  1940. _REALNUMBER :
  1941. begin
  1942. val(pattern,d,code);
  1943. if code<>0 then
  1944. begin
  1945. Message(parser_e_error_in_real);
  1946. d:=1.0;
  1947. end;
  1948. consume(_REALNUMBER);
  1949. p1:=crealconstnode.create(d,pbestrealtype^);
  1950. end;
  1951. _STRING :
  1952. begin
  1953. string_dec(htype);
  1954. { STRING can be also a type cast }
  1955. if try_to_consume(_LKLAMMER) then
  1956. begin
  1957. p1:=comp_expr(true);
  1958. consume(_RKLAMMER);
  1959. p1:=ctypeconvnode.create_explicit(p1,htype);
  1960. { handle postfix operators here e.g. string(a)[10] }
  1961. again:=true;
  1962. postfixoperators(p1,again);
  1963. end
  1964. else
  1965. p1:=ctypenode.create(htype);
  1966. end;
  1967. _FILE :
  1968. begin
  1969. htype:=cfiletype;
  1970. consume(_FILE);
  1971. { FILE can be also a type cast }
  1972. if try_to_consume(_LKLAMMER) then
  1973. begin
  1974. p1:=comp_expr(true);
  1975. consume(_RKLAMMER);
  1976. p1:=ctypeconvnode.create_explicit(p1,htype);
  1977. { handle postfix operators here e.g. string(a)[10] }
  1978. again:=true;
  1979. postfixoperators(p1,again);
  1980. end
  1981. else
  1982. begin
  1983. p1:=ctypenode.create(htype);
  1984. end;
  1985. end;
  1986. _CSTRING :
  1987. begin
  1988. p1:=cstringconstnode.createstr(pattern,st_default);
  1989. consume(_CSTRING);
  1990. end;
  1991. _CCHAR :
  1992. begin
  1993. p1:=cordconstnode.create(ord(pattern[1]),cchartype,true);
  1994. consume(_CCHAR);
  1995. end;
  1996. _CWSTRING:
  1997. begin
  1998. p1:=cstringconstnode.createwstr(patternw);
  1999. consume(_CWSTRING);
  2000. end;
  2001. _CWCHAR:
  2002. begin
  2003. p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
  2004. consume(_CWCHAR);
  2005. end;
  2006. _KLAMMERAFFE :
  2007. begin
  2008. consume(_KLAMMERAFFE);
  2009. got_addrn:=true;
  2010. { support both @<x> and @(<x>) }
  2011. if try_to_consume(_LKLAMMER) then
  2012. begin
  2013. p1:=factor(true);
  2014. if token in [_CARET,_POINT,_LECKKLAMMER] then
  2015. begin
  2016. again:=true;
  2017. postfixoperators(p1,again);
  2018. end;
  2019. consume(_RKLAMMER);
  2020. end
  2021. else
  2022. p1:=factor(true);
  2023. if token in [_CARET,_POINT,_LECKKLAMMER] then
  2024. begin
  2025. again:=true;
  2026. postfixoperators(p1,again);
  2027. end;
  2028. got_addrn:=false;
  2029. p1:=caddrnode.create(p1);
  2030. if cs_typed_addresses in aktlocalswitches then
  2031. include(p1.flags,nf_typedaddr);
  2032. { Store the procvar that we are expecting, the
  2033. addrn will use the information to find the correct
  2034. procdef or it will return an error }
  2035. if assigned(getprocvardef) and
  2036. (taddrnode(p1).left.nodetype = loadn) then
  2037. taddrnode(p1).getprocvardef:=getprocvardef;
  2038. end;
  2039. _LKLAMMER :
  2040. begin
  2041. consume(_LKLAMMER);
  2042. p1:=comp_expr(true);
  2043. consume(_RKLAMMER);
  2044. { it's not a good solution }
  2045. { but (a+b)^ makes some problems }
  2046. if token in [_CARET,_POINT,_LECKKLAMMER] then
  2047. begin
  2048. again:=true;
  2049. postfixoperators(p1,again);
  2050. end;
  2051. end;
  2052. _LECKKLAMMER :
  2053. begin
  2054. consume(_LECKKLAMMER);
  2055. p1:=factor_read_set;
  2056. consume(_RECKKLAMMER);
  2057. end;
  2058. _PLUS :
  2059. begin
  2060. consume(_PLUS);
  2061. p1:=factor(false);
  2062. end;
  2063. _MINUS :
  2064. begin
  2065. consume(_MINUS);
  2066. if (token = _INTCONST) then
  2067. begin
  2068. { ugly hack, but necessary to be able to parse }
  2069. { -9223372036854775808 as int64 (JM) }
  2070. pattern := '-'+pattern;
  2071. p1:=sub_expr(oppower,false);
  2072. { -1 ** 4 should be - (1 ** 4) and not
  2073. (-1) ** 4
  2074. This was the reason of tw0869.pp test failure PM }
  2075. if p1.nodetype=starstarn then
  2076. begin
  2077. if tbinarynode(p1).left.nodetype=ordconstn then
  2078. begin
  2079. tordconstnode(tbinarynode(p1).left).value:=-tordconstnode(tbinarynode(p1).left).value;
  2080. p1:=cunaryminusnode.create(p1);
  2081. end
  2082. else if tbinarynode(p1).left.nodetype=realconstn then
  2083. begin
  2084. trealconstnode(tbinarynode(p1).left).value_real:=-trealconstnode(tbinarynode(p1).left).value_real;
  2085. p1:=cunaryminusnode.create(p1);
  2086. end
  2087. else
  2088. internalerror(20021029);
  2089. end;
  2090. end
  2091. else
  2092. begin
  2093. p1:=sub_expr(oppower,false);
  2094. p1:=cunaryminusnode.create(p1);
  2095. end;
  2096. end;
  2097. _OP_NOT :
  2098. begin
  2099. consume(_OP_NOT);
  2100. p1:=factor(false);
  2101. p1:=cnotnode.create(p1);
  2102. end;
  2103. _TRUE :
  2104. begin
  2105. consume(_TRUE);
  2106. p1:=cordconstnode.create(1,booltype,false);
  2107. end;
  2108. _FALSE :
  2109. begin
  2110. consume(_FALSE);
  2111. p1:=cordconstnode.create(0,booltype,false);
  2112. end;
  2113. _NIL :
  2114. begin
  2115. consume(_NIL);
  2116. p1:=cnilnode.create;
  2117. { It's really ugly code nil^, but delphi allows it }
  2118. if token in [_CARET] then
  2119. begin
  2120. again:=true;
  2121. postfixoperators(p1,again);
  2122. end;
  2123. end;
  2124. else
  2125. begin
  2126. p1:=cerrornode.create;
  2127. consume(token);
  2128. Message(parser_e_illegal_expression);
  2129. end;
  2130. end;
  2131. { generate error node if no node is created }
  2132. if not assigned(p1) then
  2133. begin
  2134. {$ifdef EXTDEBUG}
  2135. Comment(V_Warning,'factor: p1=nil');
  2136. {$endif}
  2137. p1:=cerrornode.create;
  2138. end;
  2139. { get the resulttype for the node }
  2140. if (not assigned(p1.resulttype.def)) then
  2141. do_resulttypepass(p1);
  2142. factor:=p1;
  2143. check_tokenpos;
  2144. end;
  2145. {$ifdef fpc}
  2146. {$maxfpuregisters default}
  2147. {$endif fpc}
  2148. {****************************************************************************
  2149. Sub_Expr
  2150. ****************************************************************************}
  2151. const
  2152. { Warning these stay be ordered !! }
  2153. operator_levels:array[Toperator_precedence] of set of Ttoken=
  2154. ([_LT,_LTE,_GT,_GTE,_EQUAL,_UNEQUAL,_OP_IN,_OP_IS],
  2155. [_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR],
  2156. [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,
  2157. _OP_AS,_OP_AND,_AMPERSAND,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR],
  2158. [_STARSTAR] );
  2159. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):tnode;
  2160. {Reads a subexpression while the operators are of the current precedence
  2161. level, or any higher level. Replaces the old term, simpl_expr and
  2162. simpl2_expr.}
  2163. var
  2164. p1,p2 : tnode;
  2165. oldt : Ttoken;
  2166. filepos : tfileposinfo;
  2167. begin
  2168. if pred_level=highest_precedence then
  2169. p1:=factor(false)
  2170. else
  2171. p1:=sub_expr(succ(pred_level),true);
  2172. repeat
  2173. if (token in operator_levels[pred_level]) and
  2174. ((token<>_EQUAL) or accept_equal) then
  2175. begin
  2176. oldt:=token;
  2177. filepos:=akttokenpos;
  2178. consume(token);
  2179. if pred_level=highest_precedence then
  2180. p2:=factor(false)
  2181. else
  2182. p2:=sub_expr(succ(pred_level),true);
  2183. case oldt of
  2184. _PLUS :
  2185. p1:=caddnode.create(addn,p1,p2);
  2186. _MINUS :
  2187. p1:=caddnode.create(subn,p1,p2);
  2188. _STAR :
  2189. p1:=caddnode.create(muln,p1,p2);
  2190. _SLASH :
  2191. p1:=caddnode.create(slashn,p1,p2);
  2192. _EQUAL :
  2193. p1:=caddnode.create(equaln,p1,p2);
  2194. _GT :
  2195. p1:=caddnode.create(gtn,p1,p2);
  2196. _LT :
  2197. p1:=caddnode.create(ltn,p1,p2);
  2198. _GTE :
  2199. p1:=caddnode.create(gten,p1,p2);
  2200. _LTE :
  2201. p1:=caddnode.create(lten,p1,p2);
  2202. _SYMDIF :
  2203. p1:=caddnode.create(symdifn,p1,p2);
  2204. _STARSTAR :
  2205. p1:=caddnode.create(starstarn,p1,p2);
  2206. _OP_AS :
  2207. p1:=casnode.create(p1,p2);
  2208. _OP_IN :
  2209. p1:=cinnode.create(p1,p2);
  2210. _OP_IS :
  2211. p1:=cisnode.create(p1,p2);
  2212. _OP_OR,
  2213. _PIPE {macpas only} :
  2214. p1:=caddnode.create(orn,p1,p2);
  2215. _OP_AND,
  2216. _AMPERSAND {macpas only} :
  2217. p1:=caddnode.create(andn,p1,p2);
  2218. _OP_DIV :
  2219. p1:=cmoddivnode.create(divn,p1,p2);
  2220. _OP_NOT :
  2221. p1:=cnotnode.create(p1);
  2222. _OP_MOD :
  2223. p1:=cmoddivnode.create(modn,p1,p2);
  2224. _OP_SHL :
  2225. p1:=cshlshrnode.create(shln,p1,p2);
  2226. _OP_SHR :
  2227. p1:=cshlshrnode.create(shrn,p1,p2);
  2228. _OP_XOR :
  2229. p1:=caddnode.create(xorn,p1,p2);
  2230. _ASSIGNMENT :
  2231. p1:=cassignmentnode.create(p1,p2);
  2232. _CARET :
  2233. p1:=caddnode.create(caretn,p1,p2);
  2234. _UNEQUAL :
  2235. p1:=caddnode.create(unequaln,p1,p2);
  2236. end;
  2237. p1.fileinfo:=filepos;
  2238. end
  2239. else
  2240. break;
  2241. until false;
  2242. sub_expr:=p1;
  2243. end;
  2244. function comp_expr(accept_equal : boolean):tnode;
  2245. var
  2246. oldafterassignment : boolean;
  2247. p1 : tnode;
  2248. begin
  2249. oldafterassignment:=afterassignment;
  2250. afterassignment:=true;
  2251. p1:=sub_expr(opcompare,accept_equal);
  2252. { get the resulttype for this expression }
  2253. if not assigned(p1.resulttype.def) then
  2254. do_resulttypepass(p1);
  2255. afterassignment:=oldafterassignment;
  2256. comp_expr:=p1;
  2257. end;
  2258. function expr : tnode;
  2259. var
  2260. p1,p2 : tnode;
  2261. oldafterassignment : boolean;
  2262. oldp1 : tnode;
  2263. filepos : tfileposinfo;
  2264. begin
  2265. oldafterassignment:=afterassignment;
  2266. p1:=sub_expr(opcompare,true);
  2267. { get the resulttype for this expression }
  2268. if not assigned(p1.resulttype.def) then
  2269. do_resulttypepass(p1);
  2270. filepos:=akttokenpos;
  2271. if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  2272. afterassignment:=true;
  2273. oldp1:=p1;
  2274. case token of
  2275. _POINTPOINT :
  2276. begin
  2277. consume(_POINTPOINT);
  2278. p2:=sub_expr(opcompare,true);
  2279. p1:=crangenode.create(p1,p2);
  2280. end;
  2281. _ASSIGNMENT :
  2282. begin
  2283. consume(_ASSIGNMENT);
  2284. if (p1.resulttype.def.deftype=procvardef) then
  2285. getprocvardef:=tprocvardef(p1.resulttype.def);
  2286. p2:=sub_expr(opcompare,true);
  2287. if assigned(getprocvardef) then
  2288. handle_procvar(getprocvardef,p2);
  2289. getprocvardef:=nil;
  2290. p1:=cassignmentnode.create(p1,p2);
  2291. end;
  2292. _PLUSASN :
  2293. begin
  2294. consume(_PLUSASN);
  2295. p2:=sub_expr(opcompare,true);
  2296. p1:=gen_c_style_operator(addn,p1,p2);
  2297. end;
  2298. _MINUSASN :
  2299. begin
  2300. consume(_MINUSASN);
  2301. p2:=sub_expr(opcompare,true);
  2302. p1:=gen_c_style_operator(subn,p1,p2);
  2303. end;
  2304. _STARASN :
  2305. begin
  2306. consume(_STARASN );
  2307. p2:=sub_expr(opcompare,true);
  2308. p1:=gen_c_style_operator(muln,p1,p2);
  2309. end;
  2310. _SLASHASN :
  2311. begin
  2312. consume(_SLASHASN );
  2313. p2:=sub_expr(opcompare,true);
  2314. p1:=gen_c_style_operator(slashn,p1,p2);
  2315. end;
  2316. end;
  2317. { get the resulttype for this expression }
  2318. if not assigned(p1.resulttype.def) then
  2319. do_resulttypepass(p1);
  2320. afterassignment:=oldafterassignment;
  2321. if p1<>oldp1 then
  2322. p1.fileinfo:=filepos;
  2323. expr:=p1;
  2324. end;
  2325. {$ifdef int64funcresok}
  2326. function get_intconst:TConstExprInt;
  2327. {$else int64funcresok}
  2328. function get_intconst:longint;
  2329. {$endif int64funcresok}
  2330. {Reads an expression, tries to evalute it and check if it is an integer
  2331. constant. Then the constant is returned.}
  2332. var
  2333. p:tnode;
  2334. begin
  2335. result:=0;
  2336. p:=comp_expr(true);
  2337. if not codegenerror then
  2338. begin
  2339. if (p.nodetype<>ordconstn) or
  2340. not(is_integer(p.resulttype.def)) then
  2341. Message(parser_e_illegal_expression)
  2342. else
  2343. result:=tordconstnode(p).value;
  2344. end;
  2345. p.free;
  2346. end;
  2347. function get_stringconst:string;
  2348. {Reads an expression, tries to evaluate it and checks if it is a string
  2349. constant. Then the constant is returned.}
  2350. var
  2351. p:tnode;
  2352. begin
  2353. get_stringconst:='';
  2354. p:=comp_expr(true);
  2355. if p.nodetype<>stringconstn then
  2356. begin
  2357. if (p.nodetype=ordconstn) and is_char(p.resulttype.def) then
  2358. get_stringconst:=char(tordconstnode(p).value)
  2359. else
  2360. Message(parser_e_illegal_expression);
  2361. end
  2362. else
  2363. get_stringconst:=strpas(tstringconstnode(p).value_str);
  2364. p.free;
  2365. end;
  2366. end.
  2367. {
  2368. $Log$
  2369. Revision 1.179 2005-01-20 17:05:53 peter
  2370. * use val() for decoding integers
  2371. Revision 1.178 2005/01/04 16:38:07 peter
  2372. * don't allow properties in C style operators
  2373. Revision 1.177 2004/12/26 16:22:01 peter
  2374. * fix lineinfo for with blocks
  2375. Revision 1.176 2004/12/06 19:23:05 peter
  2376. implicit load of variants unit
  2377. Revision 1.175 2004/12/05 12:28:11 peter
  2378. * procvar handling for tp procvar mode fixed
  2379. * proc to procvar moved from addrnode to typeconvnode
  2380. * inlininginfo is now allocated only for inline routines that
  2381. can be inlined, introduced a new flag po_has_inlining_info
  2382. Revision 1.174 2004/11/21 17:54:59 peter
  2383. * ttempcreatenode.create_reg merged into .create with parameter
  2384. whether a register is allowed
  2385. * funcret_paraloc renamed to funcretloc
  2386. Revision 1.173 2004/11/17 22:21:35 peter
  2387. mangledname setting moved to place after the complete proc declaration is read
  2388. import generation moved to place where body is also parsed (still gives problems with win32)
  2389. Revision 1.172 2004/11/15 23:35:31 peter
  2390. * tparaitem removed, use tparavarsym instead
  2391. * parameter order is now calculated from paranr value in tparavarsym
  2392. Revision 1.171 2004/11/08 22:09:59 peter
  2393. * tvarsym splitted
  2394. Revision 1.170 2004/11/04 17:57:58 peter
  2395. added checking for token=_ID after _POINT is parsed
  2396. Revision 1.169 2004/11/01 15:32:12 peter
  2397. * support @labelsym
  2398. Revision 1.168 2004/11/01 10:33:01 peter
  2399. * symlist typeconv for absolute fixed
  2400. Revision 1.167 2004/10/25 15:38:41 peter
  2401. * heap and heapsize removed
  2402. * checkpointer fixes
  2403. Revision 1.166 2004/10/15 09:14:17 mazen
  2404. - remove $IFDEF DELPHI and related code
  2405. - remove $IFDEF FPCPROCVAR and related code
  2406. Revision 1.165 2004/10/12 19:51:13 peter
  2407. * all checking for visibility is now done by is_visible_for_object
  2408. Revision 1.164 2004/10/12 14:35:47 peter
  2409. * cstyle operators with calln in the tree now use a temp
  2410. Revision 1.163 2004/08/25 15:58:36 peter
  2411. * fix crash with calling method pointer from class procedure
  2412. Revision 1.162 2004/07/05 23:25:34 olle
  2413. + adding operators "|" and "&" for macpas
  2414. Revision 1.161 2004/07/05 21:49:43 olle
  2415. + macpas style: exit, cycle, leave
  2416. + macpas compiler directive: PUSH POP
  2417. Revision 1.160 2004/06/29 20:59:43 peter
  2418. * don't allow assigned(tobject) anymore, it is useless since it
  2419. is always true
  2420. Revision 1.159 2004/06/28 14:38:36 michael
  2421. + Patch from peter to fix typinfo for classes
  2422. Revision 1.158 2004/06/20 08:55:30 florian
  2423. * logs truncated
  2424. Revision 1.157 2004/06/16 20:07:09 florian
  2425. * dwarf branch merged
  2426. Revision 1.156 2004/05/23 18:28:41 peter
  2427. * methodpointer is loaded into a temp when it was a calln
  2428. Revision 1.155 2004/05/16 15:03:48 florian
  2429. + support for assigned(<dyn. array>) added
  2430. Revision 1.154 2004/04/29 19:56:37 daniel
  2431. * Prepare compiler infrastructure for multiple ansistring types
  2432. Revision 1.153 2004/04/12 18:59:32 florian
  2433. * small x86_64 fixes
  2434. }