pexpr.pas 96 KB

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