pexpr.pas 93 KB

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