pexpr.pas 91 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459
  1. {
  2. $Id$
  3. Copyright (c) 1998 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. interface
  20. uses symtable,tree;
  21. { reads a whole expression }
  22. function expr : ptree;
  23. { reads an expression without assignements and .. }
  24. function comp_expr(accept_equal : boolean):Ptree;
  25. { reads a single factor }
  26. function factor(getaddr : boolean) : ptree;
  27. { the ID token has to be consumed before calling this function }
  28. procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : ptree;
  29. var pd : pdef;var again : boolean);
  30. function get_intconst:longint;
  31. function get_stringconst:string;
  32. implementation
  33. uses
  34. globtype,systems,tokens,
  35. cobjects,globals,scanner,aasm,pass_1,
  36. hcodegen,types,verbose,strings,tccal
  37. { parser specific stuff }
  38. ,pbase,pdecl
  39. { processor specific stuff }
  40. {$ifdef i386}
  41. ,i386base
  42. {$endif}
  43. {$ifdef m68k}
  44. ,m68k
  45. {$endif}
  46. ;
  47. const allow_type : boolean = true;
  48. function parse_paras(_colon,in_prop_paras : boolean) : ptree;
  49. var
  50. p1,p2 : ptree;
  51. end_of_paras : ttoken;
  52. begin
  53. if in_prop_paras then
  54. end_of_paras:=RECKKLAMMER
  55. else
  56. end_of_paras:=RKLAMMER;
  57. if token=end_of_paras then
  58. begin
  59. parse_paras:=nil;
  60. exit;
  61. end;
  62. p2:=nil;
  63. inc(parsing_para_level);
  64. while true do
  65. begin
  66. p1:=comp_expr(true);
  67. p2:=gencallparanode(p1,p2);
  68. { it's for the str(l:5,s); }
  69. if _colon and (token=COLON) then
  70. begin
  71. consume(COLON);
  72. p1:=comp_expr(true);
  73. p2:=gencallparanode(p1,p2);
  74. p2^.is_colon_para:=true;
  75. if token=COLON then
  76. begin
  77. consume(COLON);
  78. p1:=comp_expr(true);
  79. p2:=gencallparanode(p1,p2);
  80. p2^.is_colon_para:=true;
  81. end
  82. end;
  83. if token=COMMA then
  84. consume(COMMA)
  85. else
  86. break;
  87. end;
  88. dec(parsing_para_level);
  89. parse_paras:=p2;
  90. end;
  91. function statement_syssym(l : longint;var pd : pdef) : ptree;
  92. var
  93. p1,p2,paras : ptree;
  94. prev_in_args : boolean;
  95. Store_valid : boolean;
  96. begin
  97. prev_in_args:=in_args;
  98. Store_valid:=Must_be_valid;
  99. case l of
  100. in_ord_x :
  101. begin
  102. consume(LKLAMMER);
  103. in_args:=true;
  104. Must_be_valid:=true;
  105. p1:=comp_expr(true);
  106. consume(RKLAMMER);
  107. do_firstpass(p1);
  108. p1:=geninlinenode(in_ord_x,false,p1);
  109. do_firstpass(p1);
  110. statement_syssym := p1;
  111. pd:=p1^.resulttype;
  112. end;
  113. in_break :
  114. begin
  115. statement_syssym:=genzeronode(breakn);
  116. pd:=voiddef;
  117. end;
  118. in_continue :
  119. begin
  120. statement_syssym:=genzeronode(continuen);
  121. pd:=voiddef;
  122. end;
  123. in_typeof_x :
  124. begin
  125. consume(LKLAMMER);
  126. in_args:=true;
  127. {allow_type:=true;}
  128. p1:=comp_expr(true);
  129. {allow_type:=false;}
  130. consume(RKLAMMER);
  131. pd:=voidpointerdef;
  132. if p1^.treetype=typen then
  133. begin
  134. if (p1^.typenodetype=nil) then
  135. begin
  136. Message(type_e_mismatch);
  137. statement_syssym:=genzeronode(errorn);
  138. end
  139. else
  140. if p1^.typenodetype^.deftype=objectdef then
  141. begin
  142. { we can use resulttype in pass_2 (PM) }
  143. p1^.resulttype:=p1^.typenodetype;
  144. statement_syssym:=geninlinenode(in_typeof_x,false,p1);
  145. end
  146. else
  147. begin
  148. Message(type_e_mismatch);
  149. disposetree(p1);
  150. statement_syssym:=genzeronode(errorn);
  151. end;
  152. end
  153. else { not a type node }
  154. begin
  155. Must_be_valid:=false;
  156. do_firstpass(p1);
  157. if (p1^.resulttype=nil) then
  158. begin
  159. Message(type_e_mismatch);
  160. disposetree(p1);
  161. statement_syssym:=genzeronode(errorn)
  162. end
  163. else
  164. if p1^.resulttype^.deftype=objectdef then
  165. statement_syssym:=geninlinenode(in_typeof_x,false,p1)
  166. else
  167. begin
  168. Message(type_e_mismatch);
  169. statement_syssym:=genzeronode(errorn);
  170. disposetree(p1);
  171. end;
  172. end;
  173. end;
  174. in_sizeof_x :
  175. begin
  176. consume(LKLAMMER);
  177. in_args:=true;
  178. {allow_type:=true;}
  179. p1:=comp_expr(true);
  180. {allow_type:=false; }
  181. consume(RKLAMMER);
  182. pd:=s32bitdef;
  183. if p1^.treetype=typen then
  184. begin
  185. statement_syssym:=genordinalconstnode(p1^.typenodetype^.size,pd);
  186. { p1 not needed !}
  187. disposetree(p1);
  188. end
  189. else
  190. begin
  191. Must_be_valid:=false;
  192. do_firstpass(p1);
  193. if ((p1^.resulttype^.deftype=objectdef) and
  194. ((pobjectdef(p1^.resulttype)^.options and oo_hasconstructor)<>0)) or
  195. is_open_array(p1^.resulttype) or
  196. is_open_string(p1^.resulttype) then
  197. statement_syssym:=geninlinenode(in_sizeof_x,false,p1)
  198. else
  199. begin
  200. statement_syssym:=genordinalconstnode(p1^.resulttype^.size,pd);
  201. { p1 not needed !}
  202. disposetree(p1);
  203. end;
  204. end;
  205. end;
  206. in_assigned_x :
  207. begin
  208. consume(LKLAMMER);
  209. in_args:=true;
  210. p1:=comp_expr(true);
  211. Must_be_valid:=true;
  212. do_firstpass(p1);
  213. case p1^.resulttype^.deftype of
  214. pointerdef,
  215. procvardef,
  216. classrefdef : ;
  217. objectdef : if not(pobjectdef(p1^.resulttype)^.isclass) then
  218. Message(parser_e_illegal_parameter_list);
  219. else
  220. Message(parser_e_illegal_parameter_list);
  221. end;
  222. p2:=gencallparanode(p1,nil);
  223. p2:=geninlinenode(in_assigned_x,false,p2);
  224. consume(RKLAMMER);
  225. pd:=booldef;
  226. statement_syssym:=p2;
  227. end;
  228. in_ofs_x :
  229. begin
  230. consume(LKLAMMER);
  231. in_args:=true;
  232. p1:=comp_expr(true);
  233. p1:=gensinglenode(addrn,p1);
  234. Must_be_valid:=false;
  235. do_firstpass(p1);
  236. { Ofs() returns a longint, not a pointer }
  237. p1^.resulttype:=u32bitdef;
  238. pd:=p1^.resulttype;
  239. consume(RKLAMMER);
  240. statement_syssym:=p1;
  241. end;
  242. in_addr_x :
  243. begin
  244. consume(LKLAMMER);
  245. in_args:=true;
  246. p1:=comp_expr(true);
  247. p1:=gensinglenode(addrn,p1);
  248. Must_be_valid:=false;
  249. do_firstpass(p1);
  250. pd:=p1^.resulttype;
  251. consume(RKLAMMER);
  252. statement_syssym:=p1;
  253. end;
  254. in_seg_x :
  255. begin
  256. consume(LKLAMMER);
  257. in_args:=true;
  258. p1:=comp_expr(true);
  259. do_firstpass(p1);
  260. if p1^.location.loc<>LOC_REFERENCE then
  261. Message(cg_e_illegal_expression);
  262. p1:=genordinalconstnode(0,s32bitdef);
  263. Must_be_valid:=false;
  264. pd:=s32bitdef;
  265. consume(RKLAMMER);
  266. statement_syssym:=p1;
  267. end;
  268. in_high_x,
  269. in_low_x :
  270. begin
  271. consume(LKLAMMER);
  272. in_args:=true;
  273. {allow_type:=true;}
  274. p1:=comp_expr(true);
  275. {allow_type:=false;}
  276. do_firstpass(p1);
  277. if p1^.treetype=typen then
  278. p1^.resulttype:=p1^.typenodetype;
  279. Must_be_valid:=false;
  280. p2:=geninlinenode(l,false,p1);
  281. consume(RKLAMMER);
  282. pd:=s32bitdef;
  283. statement_syssym:=p2;
  284. end;
  285. in_succ_x,
  286. in_pred_x :
  287. begin
  288. consume(LKLAMMER);
  289. in_args:=true;
  290. p1:=comp_expr(true);
  291. do_firstpass(p1);
  292. Must_be_valid:=false;
  293. p2:=geninlinenode(l,false,p1);
  294. consume(RKLAMMER);
  295. pd:=p1^.resulttype;
  296. statement_syssym:=p2;
  297. end;
  298. in_inc_x,
  299. in_dec_x :
  300. begin
  301. consume(LKLAMMER);
  302. in_args:=true;
  303. p1:=comp_expr(true);
  304. Must_be_valid:=false;
  305. if token=COMMA then
  306. begin
  307. consume(COMMA);
  308. p2:=gencallparanode(comp_expr(true),nil);
  309. end
  310. else
  311. p2:=nil;
  312. p2:=gencallparanode(p1,p2);
  313. statement_syssym:=geninlinenode(l,false,p2);
  314. consume(RKLAMMER);
  315. pd:=voiddef;
  316. end;
  317. in_concat_x :
  318. begin
  319. consume(LKLAMMER);
  320. in_args:=true;
  321. p2:=nil;
  322. while true do
  323. begin
  324. p1:=comp_expr(true);
  325. Must_be_valid:=true;
  326. do_firstpass(p1);
  327. if not((p1^.resulttype^.deftype=stringdef) or
  328. ((p1^.resulttype^.deftype=orddef) and
  329. (porddef(p1^.resulttype)^.typ=uchar))) then
  330. Message(parser_e_illegal_parameter_list);
  331. if p2<>nil then
  332. p2:=gennode(addn,p2,p1)
  333. else
  334. p2:=p1;
  335. if token=COMMA then
  336. consume(COMMA)
  337. else
  338. break;
  339. end;
  340. consume(RKLAMMER);
  341. pd:=cshortstringdef;
  342. statement_syssym:=p2;
  343. end;
  344. in_read_x,
  345. in_readln_x :
  346. begin
  347. if token=LKLAMMER then
  348. begin
  349. consume(LKLAMMER);
  350. in_args:=true;
  351. Must_be_valid:=false;
  352. paras:=parse_paras(false,false);
  353. consume(RKLAMMER);
  354. end
  355. else
  356. paras:=nil;
  357. pd:=voiddef;
  358. p1:=geninlinenode(l,false,paras);
  359. do_firstpass(p1);
  360. statement_syssym := p1;
  361. end;
  362. in_write_x,
  363. in_writeln_x :
  364. begin
  365. if token=LKLAMMER then
  366. begin
  367. consume(LKLAMMER);
  368. in_args:=true;
  369. Must_be_valid:=true;
  370. paras:=parse_paras(true,false);
  371. consume(RKLAMMER);
  372. end
  373. else
  374. paras:=nil;
  375. pd:=voiddef;
  376. p1 := geninlinenode(l,false,paras);
  377. do_firstpass(p1);
  378. statement_syssym := p1;
  379. end;
  380. in_str_x_string :
  381. begin
  382. consume(LKLAMMER);
  383. in_args:=true;
  384. paras:=parse_paras(true,false);
  385. consume(RKLAMMER);
  386. p1 := geninlinenode(l,false,paras);
  387. do_firstpass(p1);
  388. statement_syssym := p1;
  389. pd:=voiddef;
  390. end;
  391. {$IfnDef OLDVAL}
  392. in_val_x:
  393. Begin
  394. consume(LKLAMMER);
  395. in_args := true;
  396. p1:= gencallparanode(comp_expr(true), nil);
  397. Must_be_valid := False;
  398. consume(COMMA);
  399. p2 := gencallparanode(comp_expr(true),p1);
  400. if (token = COMMA) then
  401. Begin
  402. consume(COMMA);
  403. p2 := gencallparanode(comp_expr(true),p2)
  404. End;
  405. consume(RKLAMMER);
  406. p2 := geninlinenode(l,false,p2);
  407. do_firstpass(p2);
  408. statement_syssym := p2;
  409. pd := voiddef;
  410. End;
  411. {$EndIf OLDVAL}
  412. in_include_x_y,
  413. in_exclude_x_y :
  414. begin
  415. consume(LKLAMMER);
  416. in_args:=true;
  417. p1:=comp_expr(true);
  418. Must_be_valid:=false;
  419. consume(COMMA);
  420. p2:=comp_expr(true);
  421. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  422. consume(RKLAMMER);
  423. pd:=voiddef;
  424. end;
  425. in_assert_x_y :
  426. begin
  427. consume(LKLAMMER);
  428. in_args:=true;
  429. p1:=comp_expr(true);
  430. if token=COMMA then
  431. begin
  432. consume(COMMA);
  433. p2:=comp_expr(true);
  434. end
  435. else
  436. begin
  437. { then insert an empty string }
  438. p2:=genstringconstnode('');
  439. end;
  440. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  441. consume(RKLAMMER);
  442. pd:=voiddef;
  443. end;
  444. else
  445. internalerror(15);
  446. end;
  447. in_args:=prev_in_args;
  448. Must_be_valid:=Store_valid;
  449. end;
  450. { reads the parameter for a subroutine call }
  451. procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
  452. var
  453. prev_in_args : boolean;
  454. prevafterassn : boolean;
  455. begin
  456. prev_in_args:=in_args;
  457. prevafterassn:=afterassignment;
  458. afterassignment:=false;
  459. { want we only determine the address of }
  460. { a subroutine ? }
  461. if not(getaddr) then
  462. begin
  463. if token=LKLAMMER then
  464. begin
  465. consume(LKLAMMER);
  466. in_args:=true;
  467. p1^.left:=parse_paras(false,false);
  468. consume(RKLAMMER);
  469. end
  470. else p1^.left:=nil;
  471. { do firstpass because we need the }
  472. { result type }
  473. do_firstpass(p1);
  474. end
  475. else
  476. begin
  477. { address operator @: }
  478. p1^.left:=nil;
  479. { forget pd }
  480. pd:=nil;
  481. if (p1^.symtableproc^.symtabletype=withsymtable) and
  482. (p1^.symtableproc^.defowner^.deftype=objectdef) then
  483. begin
  484. p1^.methodpointer:=getcopy(pwithsymtable(p1^.symtableproc)^.withrefnode);
  485. end;
  486. { no postfix operators }
  487. again:=false;
  488. end;
  489. pd:=p1^.resulttype;
  490. in_args:=prev_in_args;
  491. afterassignment:=prevafterassn;
  492. end;
  493. procedure handle_procvar(procvar : pprocvardef;var t : ptree);
  494. var
  495. hp : ptree;
  496. begin
  497. hp:=nil;
  498. if ((procvar^.options and pomethodpointer)<>0) then
  499. begin
  500. if assigned(t^.methodpointer) and
  501. (t^.methodpointer^.resulttype^.deftype=objectdef) and
  502. (pobjectdef(t^.methodpointer^.resulttype)^.isclass) and
  503. (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
  504. hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
  505. else
  506. Message(type_e_mismatch);
  507. end
  508. else if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,getprocvardef)) then
  509. begin
  510. hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
  511. end;
  512. if assigned(hp) then
  513. begin
  514. disposetree(t);
  515. t:=hp;
  516. end;
  517. end;
  518. { the following procedure handles the access to a property symbol }
  519. procedure handle_propertysym(sym : psym;st : psymtable;var p1 : ptree;
  520. var pd : pdef);
  521. var
  522. paras : ptree;
  523. p2 : ptree;
  524. begin
  525. paras:=nil;
  526. { property parameters? }
  527. if token=LECKKLAMMER then
  528. begin
  529. consume(LECKKLAMMER);
  530. paras:=parse_paras(false,true);
  531. consume(RECKKLAMMER);
  532. end;
  533. { indexed property }
  534. if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
  535. begin
  536. p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
  537. paras:=gencallparanode(p2,paras);
  538. end;
  539. { we need only a write property if a := follows }
  540. { if not(afterassignment) and not(in_args) then }
  541. if token=ASSIGNMENT then
  542. begin
  543. { write property: }
  544. { no result }
  545. pd:=voiddef;
  546. if assigned(ppropertysym(sym)^.writeaccesssym) then
  547. begin
  548. if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
  549. begin
  550. { generate the method call }
  551. p1:=genmethodcallnode(pprocsym(
  552. ppropertysym(sym)^.writeaccesssym),st,p1);
  553. { we know the procedure to call, so
  554. force the usage of that procedure }
  555. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccessdef);
  556. p1^.left:=paras;
  557. consume(ASSIGNMENT);
  558. { read the expression }
  559. getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
  560. p2:=comp_expr(true);
  561. if (p2^.treetype<>errorn) and getprocvar then
  562. handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2);
  563. p1^.left:=gencallparanode(p2,p1^.left);
  564. { firstcallparan(p1^.left,nil); }
  565. getprocvar:=false;
  566. end
  567. else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
  568. begin
  569. if assigned(paras) then
  570. message(parser_e_no_paras_allowed);
  571. { subscribed access? }
  572. if p1=nil then
  573. p1:=genloadnode(pvarsym(ppropertysym(sym)^.writeaccesssym),st)
  574. else
  575. p1:=gensubscriptnode(pvarsym(ppropertysym(sym)^.writeaccesssym),p1);
  576. consume(ASSIGNMENT);
  577. { read the expression }
  578. p2:=comp_expr(true);
  579. p1:=gennode(assignn,p1,p2);
  580. end
  581. else
  582. begin
  583. p1:=genzeronode(errorn);
  584. Message(parser_e_no_procedure_to_access_property);
  585. end;
  586. end
  587. else
  588. begin
  589. p1:=genzeronode(errorn);
  590. Message(parser_e_no_procedure_to_access_property);
  591. end;
  592. end
  593. else
  594. begin
  595. { read property: }
  596. pd:=ppropertysym(sym)^.proptype;
  597. if assigned(ppropertysym(sym)^.readaccesssym) then
  598. begin
  599. if ppropertysym(sym)^.readaccesssym^.typ=varsym then
  600. begin
  601. if assigned(paras) then
  602. message(parser_e_no_paras_allowed);
  603. { subscribed access? }
  604. if p1=nil then
  605. p1:=genloadnode(pvarsym(ppropertysym(sym)^.readaccesssym),st)
  606. else
  607. p1:=gensubscriptnode(pvarsym(ppropertysym(sym)^.readaccesssym),p1);
  608. end
  609. else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
  610. begin
  611. { generate the method call }
  612. p1:=genmethodcallnode(pprocsym(ppropertysym(sym)^.readaccesssym),st,p1);
  613. { we know the procedure to call, so
  614. force the usage of that procedure }
  615. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.readaccessdef);
  616. { insert paras }
  617. p1^.left:=paras;
  618. end
  619. else
  620. begin
  621. p1:=genzeronode(errorn);
  622. Message(type_e_mismatch);
  623. end;
  624. end
  625. else
  626. begin
  627. { error, no function to read property }
  628. p1:=genzeronode(errorn);
  629. Message(parser_e_no_procedure_to_access_property);
  630. end;
  631. end;
  632. end;
  633. { the ID token has to be consumed before calling this function }
  634. procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : ptree;
  635. var pd : pdef;var again : boolean);
  636. var
  637. static_name : string;
  638. isclassref : boolean;
  639. begin
  640. if sym=nil then
  641. begin
  642. { pattern is still valid unless
  643. there is another ID just after the ID of sym }
  644. Message1(sym_e_id_no_member,pattern);
  645. disposetree(p1);
  646. p1:=genzeronode(errorn);
  647. { try to clean up }
  648. pd:=generrordef;
  649. again:=false;
  650. end
  651. else
  652. begin
  653. isclassref:=pd^.deftype=classrefdef;
  654. { check protected and private members }
  655. { please leave this code as it is, }
  656. { it has now the same behaviaor as TP/Delphi }
  657. if ((sym^.properties and sp_private)<>0) and
  658. (pobjectdef(pd)^.owner^.symtabletype=unitsymtable) then
  659. Message(parser_e_cant_access_private_member);
  660. if ((sym^.properties and sp_protected)<>0) and
  661. (pobjectdef(pd)^.owner^.symtabletype=unitsymtable) then
  662. begin
  663. if assigned(aktprocsym^.definition^._class) then
  664. begin
  665. if not aktprocsym^.definition^._class^.isrelated(
  666. pobjectdef(sym^.owner^.defowner)) then
  667. Message(parser_e_cant_access_protected_member);
  668. end
  669. else
  670. Message(parser_e_cant_access_protected_member);
  671. end;
  672. { we assume, that only procsyms and varsyms are in an object }
  673. { symbol table, for classes, properties are allowed }
  674. case sym^.typ of
  675. procsym:
  676. begin
  677. p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
  678. do_proc_call(getaddr or
  679. (getprocvar and
  680. proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
  681. ,again,p1,pd);
  682. { now we know the real method e.g. we can check for }
  683. { a class method }
  684. if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
  685. Message(parser_e_only_class_methods_via_class_ref);
  686. end;
  687. varsym:
  688. begin
  689. if isclassref then
  690. Message(parser_e_only_class_methods_via_class_ref);
  691. if (sym^.properties and sp_static)<>0 then
  692. begin
  693. { static_name:=lower(srsymtable^.name^)+'_'+sym^.name;
  694. this is wrong for static field in with symtable (PM) }
  695. static_name:=lower(srsym^.owner^.name^)+'_'+sym^.name;
  696. getsym(static_name,true);
  697. disposetree(p1);
  698. p1:=genloadnode(pvarsym(srsym),srsymtable);
  699. end
  700. else
  701. p1:=gensubscriptnode(pvarsym(sym),p1);
  702. pd:=pvarsym(sym)^.definition;
  703. end;
  704. propertysym:
  705. begin
  706. if isclassref then
  707. Message(parser_e_only_class_methods_via_class_ref);
  708. handle_propertysym(sym,srsymtable,p1,pd);
  709. end;
  710. else internalerror(16);
  711. end;
  712. end;
  713. end;
  714. {****************************************************************************
  715. Factor
  716. ****************************************************************************}
  717. function factor(getaddr : boolean) : ptree;
  718. var
  719. l : longint;
  720. oldp1,
  721. p1,p2,p3 : ptree;
  722. code : integer;
  723. pd,pd2 : pdef;
  724. possible_error,
  725. unit_specific,
  726. again : boolean;
  727. sym : pvarsym;
  728. classh : pobjectdef;
  729. d : bestreal;
  730. static_name : string;
  731. propsym : ppropertysym;
  732. filepos : tfileposinfo;
  733. {---------------------------------------------
  734. Is_func_ret
  735. ---------------------------------------------}
  736. function is_func_ret(sym : psym) : boolean;
  737. var
  738. p : pprocinfo;
  739. storesymtablestack : psymtable;
  740. begin
  741. is_func_ret:=false;
  742. if (sym^.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0) then
  743. exit;
  744. p:=@procinfo;
  745. while system.assigned(p) do
  746. begin
  747. { is this an access to a function result ? }
  748. if assigned(p^.funcretsym) and
  749. ((pfuncretsym(sym)=p^.funcretsym) or
  750. ((pvarsym(sym)=opsym) and
  751. ((p^.flags and pi_operator)<>0))) and
  752. (p^.retdef<>pdef(voiddef)) and
  753. (token<>LKLAMMER) and
  754. (not ((m_tp in aktmodeswitches) and
  755. (afterassignment or in_args))) then
  756. begin
  757. p1:=genzeronode(funcretn);
  758. pd:=p^.retdef;
  759. p1^.funcretprocinfo:=p;
  760. p1^.retdef:=pd;
  761. is_func_ret:=true;
  762. exit;
  763. end;
  764. p:=p^.parent;
  765. end;
  766. { we must use the function call }
  767. if(sym^.typ=funcretsym) then
  768. begin
  769. storesymtablestack:=symtablestack;
  770. symtablestack:=srsymtable^.next;
  771. getsym(sym^.name,true);
  772. if srsym^.typ<>procsym then
  773. Message(cg_e_illegal_expression);
  774. symtablestack:=storesymtablestack;
  775. end;
  776. end;
  777. {---------------------------------------------
  778. Factor_read_id
  779. ---------------------------------------------}
  780. procedure factor_read_id;
  781. var
  782. pc : pchar;
  783. len : longint;
  784. begin
  785. { allow post fix operators }
  786. again:=true;
  787. if (m_result in aktmodeswitches) and
  788. (idtoken=_RESULT) and
  789. assigned(aktprocsym) and
  790. (procinfo.retdef<>pdef(voiddef)) then
  791. begin
  792. consume(ID);
  793. p1:=genzeronode(funcretn);
  794. pd:=procinfo.retdef;
  795. p1^.funcretprocinfo:=pointer(@procinfo);
  796. p1^.retdef:=pd;
  797. end
  798. else
  799. begin
  800. if lastsymknown then
  801. begin
  802. srsym:=lastsrsym;
  803. srsymtable:=lastsrsymtable;
  804. lastsymknown:=false;
  805. end
  806. else
  807. getsym(pattern,true);
  808. consume(ID);
  809. if not is_func_ret(srsym) then
  810. { else it's a normal symbol }
  811. begin
  812. { is it defined like UNIT.SYMBOL ? }
  813. if srsym^.typ=unitsym then
  814. begin
  815. consume(POINT);
  816. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  817. unit_specific:=true;
  818. consume(ID);
  819. end
  820. else
  821. unit_specific:=false;
  822. if not assigned(srsym) then
  823. Begin
  824. p1:=genzeronode(errorn);
  825. { try to clean up }
  826. pd:=generrordef;
  827. end
  828. else
  829. Begin
  830. { check semantics of private }
  831. if (srsym^.typ in [propertysym,procsym,varsym]) and
  832. (srsymtable^.symtabletype=objectsymtable) then
  833. begin
  834. if ((srsym^.properties and sp_private)<>0) and
  835. (pobjectdef(srsym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then
  836. Message(parser_e_cant_access_private_member);
  837. end;
  838. case srsym^.typ of
  839. absolutesym : begin
  840. p1:=genloadnode(pvarsym(srsym),srsymtable);
  841. pd:=pabsolutesym(srsym)^.definition;
  842. end;
  843. varsym : begin
  844. { are we in a class method ? }
  845. if (srsymtable^.symtabletype=objectsymtable) and
  846. assigned(aktprocsym) and
  847. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  848. Message(parser_e_only_class_methods);
  849. if (srsym^.properties and sp_static)<>0 then
  850. begin
  851. static_name:=lower(srsym^.owner^.name^)+'_'+srsym^.name;
  852. getsym(static_name,true);
  853. end;
  854. p1:=genloadnode(pvarsym(srsym),srsymtable);
  855. if pvarsym(srsym)^.is_valid=0 then
  856. begin
  857. p1^.is_first := true;
  858. { set special between first loaded until checked in firstpass }
  859. pvarsym(srsym)^.is_valid:=2;
  860. end;
  861. pd:=pvarsym(srsym)^.definition;
  862. end;
  863. typedconstsym : begin
  864. p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
  865. pd:=ptypedconstsym(srsym)^.definition;
  866. end;
  867. syssym : p1:=statement_syssym(psyssym(srsym)^.number,pd);
  868. typesym : begin
  869. pd:=ptypesym(srsym)^.definition;
  870. if not assigned(pd) then
  871. begin
  872. pd:=generrordef;
  873. again:=false;
  874. end
  875. else
  876. { if we read a type declaration }
  877. { we have to return the type and }
  878. { nothing else }
  879. if block_type=bt_type then
  880. begin
  881. p1:=gentypenode(pd);
  882. { here we can also set resulttype !! }
  883. p1^.resulttype:=pd;
  884. pd:=voiddef;
  885. end
  886. else { not type block }
  887. begin
  888. if token=LKLAMMER then
  889. begin
  890. consume(LKLAMMER);
  891. p1:=comp_expr(true);
  892. consume(RKLAMMER);
  893. p1:=gentypeconvnode(p1,pd);
  894. p1^.explizit:=true;
  895. end
  896. else { not LKLAMMER}
  897. if (token=POINT) and
  898. (pd^.deftype=objectdef) and
  899. not(pobjectdef(pd)^.isclass) then
  900. begin
  901. consume(POINT);
  902. if assigned(procinfo._class) then
  903. begin
  904. if procinfo._class^.isrelated(pobjectdef(pd)) then
  905. begin
  906. p1:=gentypenode(pd);
  907. p1^.resulttype:=pd;
  908. srsymtable:=pobjectdef(pd)^.publicsyms;
  909. sym:=pvarsym(srsymtable^.search(pattern));
  910. { search also in inherited methods }
  911. while sym=nil do
  912. begin
  913. pd:=pobjectdef(pd)^.childof;
  914. srsymtable:=pobjectdef(pd)^.publicsyms;
  915. sym:=pvarsym(srsymtable^.search(pattern));
  916. end;
  917. consume(ID);
  918. do_member_read(false,sym,p1,pd,again);
  919. end
  920. else
  921. begin
  922. Message(parser_e_no_super_class);
  923. pd:=generrordef;
  924. again:=false;
  925. end;
  926. end
  927. else
  928. begin
  929. { allows @TObject.Load }
  930. { also allows static methods and variables }
  931. p1:=genzeronode(typen);
  932. p1^.resulttype:=pd;
  933. { srsymtable:=pobjectdef(pd)^.publicsyms;
  934. sym:=pvarsym(srsymtable^.search(pattern)); }
  935. { TP allows also @TMenu.Load if Load is only }
  936. { defined in an anchestor class }
  937. sym:=pvarsym(search_class_member(pobjectdef(pd),pattern));
  938. if not assigned(sym) then
  939. Message1(sym_e_id_no_member,pattern)
  940. else if not(getaddr) and ((sym^.properties and sp_static)=0) then
  941. Message(sym_e_only_static_in_static)
  942. else
  943. begin
  944. consume(ID);
  945. do_member_read(getaddr,sym,p1,pd,again);
  946. end;
  947. end;
  948. end
  949. else
  950. begin
  951. { class reference ? }
  952. if (pd^.deftype=objectdef)
  953. and pobjectdef(pd)^.isclass then
  954. begin
  955. p1:=gentypenode(pd);
  956. p1^.resulttype:=pd;
  957. pd:=new(pclassrefdef,init(pd));
  958. p1:=gensinglenode(loadvmtn,p1);
  959. p1^.resulttype:=pd;
  960. end
  961. else
  962. begin
  963. { generate a type node }
  964. { (for typeof etc) }
  965. if allow_type then
  966. begin
  967. p1:=gentypenode(pd);
  968. { here we must use typenodetype explicitly !! PM
  969. p1^.resulttype:=pd; }
  970. pd:=voiddef;
  971. end
  972. else
  973. Message(parser_e_no_type_not_allowed_here);
  974. end;
  975. end;
  976. end;
  977. end;
  978. enumsym : begin
  979. p1:=genenumnode(penumsym(srsym));
  980. pd:=p1^.resulttype;
  981. end;
  982. constsym : begin
  983. case pconstsym(srsym)^.consttype of
  984. constint :
  985. p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
  986. conststring :
  987. begin
  988. len:=pconstsym(srsym)^.len;
  989. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  990. len:=255;
  991. getmem(pc,len+1);
  992. move(pchar(pconstsym(srsym)^.value)^,pc^,len);
  993. pc[len]:=#0;
  994. p1:=genpcharconstnode(pc,len);
  995. end;
  996. constchar :
  997. p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
  998. constreal :
  999. p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^,bestrealdef^);
  1000. constbool :
  1001. p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
  1002. constset :
  1003. p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
  1004. psetdef(pconstsym(srsym)^.definition));
  1005. constord :
  1006. p1:=genordinalconstnode(pconstsym(srsym)^.value,
  1007. pconstsym(srsym)^.definition);
  1008. constnil :
  1009. p1:=genzeronode(niln);
  1010. end;
  1011. pd:=p1^.resulttype;
  1012. end;
  1013. procsym : begin
  1014. { are we in a class method ? }
  1015. possible_error:=(srsymtable^.symtabletype=objectsymtable) and
  1016. assigned(aktprocsym) and
  1017. ((aktprocsym^.definition^.options and poclassmethod)<>0);
  1018. p1:=gencallnode(pprocsym(srsym),srsymtable);
  1019. p1^.unit_specific:=unit_specific;
  1020. do_proc_call(getaddr or
  1021. (getprocvar and
  1022. proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
  1023. again,p1,pd);
  1024. if possible_error and
  1025. ((p1^.procdefinition^.options and poclassmethod)=0) then
  1026. Message(parser_e_only_class_methods);
  1027. end;
  1028. propertysym : begin
  1029. { access to property in a method }
  1030. { are we in a class method ? }
  1031. if (srsymtable^.symtabletype=objectsymtable) and
  1032. assigned(aktprocsym) and
  1033. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  1034. Message(parser_e_only_class_methods);
  1035. { no method pointer }
  1036. p1:=nil;
  1037. handle_propertysym(srsym,srsymtable,p1,pd);
  1038. end;
  1039. errorsym : begin
  1040. p1:=genzeronode(errorn);
  1041. pd:=generrordef;
  1042. if token=LKLAMMER then
  1043. begin
  1044. consume(LKLAMMER);
  1045. parse_paras(false,false);
  1046. consume(RKLAMMER);
  1047. end;
  1048. end;
  1049. else
  1050. begin
  1051. p1:=genzeronode(errorn);
  1052. pd:=generrordef;
  1053. Message(cg_e_illegal_expression);
  1054. end;
  1055. end; { end case }
  1056. end;
  1057. end;
  1058. end;
  1059. end;
  1060. {---------------------------------------------
  1061. Factor_Read_Set
  1062. ---------------------------------------------}
  1063. { Read a set between [] }
  1064. function factor_read_set:ptree;
  1065. var
  1066. p1,
  1067. lastp,
  1068. buildp : ptree;
  1069. begin
  1070. buildp:=nil;
  1071. { be sure that a least one arrayconstructn is used, also for an
  1072. empty [] }
  1073. if token=RECKKLAMMER then
  1074. buildp:=gennode(arrayconstructn,nil,buildp)
  1075. else
  1076. begin
  1077. while true do
  1078. begin
  1079. p1:=comp_expr(true);
  1080. if token=POINTPOINT then
  1081. begin
  1082. consume(POINTPOINT);
  1083. p2:=comp_expr(true);
  1084. p1:=gennode(arrayconstructrangen,p1,p2);
  1085. end;
  1086. { insert at the end of the tree, to get the correct order }
  1087. if not assigned(buildp) then
  1088. begin
  1089. buildp:=gennode(arrayconstructn,p1,nil);
  1090. lastp:=buildp;
  1091. end
  1092. else
  1093. begin
  1094. lastp^.right:=gennode(arrayconstructn,p1,nil);
  1095. lastp:=lastp^.right;
  1096. end;
  1097. { there could be more elements }
  1098. if token=COMMA then
  1099. consume(COMMA)
  1100. else
  1101. break;
  1102. end;
  1103. end;
  1104. factor_read_set:=buildp;
  1105. end;
  1106. {---------------------------------------------
  1107. Helpers
  1108. ---------------------------------------------}
  1109. procedure check_tokenpos;
  1110. begin
  1111. if (p1<>oldp1) then
  1112. begin
  1113. if assigned(p1) then
  1114. set_tree_filepos(p1,filepos);
  1115. oldp1:=p1;
  1116. filepos:=tokenpos;
  1117. end;
  1118. end;
  1119. {---------------------------------------------
  1120. PostFixOperators
  1121. ---------------------------------------------}
  1122. procedure postfixoperators;
  1123. var
  1124. store_static : boolean;
  1125. { p1 and p2 must contain valid value_str }
  1126. begin
  1127. check_tokenpos;
  1128. while again do
  1129. begin
  1130. { prevent crashes with unknown types }
  1131. if not assigned(pd) then
  1132. begin
  1133. { try to recover }
  1134. repeat
  1135. case token of
  1136. CARET:
  1137. consume(CARET);
  1138. POINT:
  1139. begin
  1140. consume(POINT);
  1141. consume(ID);
  1142. end;
  1143. LECKKLAMMER:
  1144. begin
  1145. repeat
  1146. consume(token);
  1147. until token in [RECKKLAMMER,SEMICOLON];
  1148. end;
  1149. else
  1150. break;
  1151. end;
  1152. until false;
  1153. exit;
  1154. end;
  1155. { handle token }
  1156. case token of
  1157. CARET:
  1158. begin
  1159. consume(CARET);
  1160. if (pd^.deftype<>pointerdef) then
  1161. begin
  1162. { ^ as binary operator is a problem!!!! (FK) }
  1163. again:=false;
  1164. Message(cg_e_invalid_qualifier);
  1165. disposetree(p1);
  1166. p1:=genzeronode(errorn);
  1167. end
  1168. else
  1169. begin
  1170. p1:=gensinglenode(derefn,p1);
  1171. pd:=ppointerdef(pd)^.definition;
  1172. end;
  1173. end;
  1174. LECKKLAMMER:
  1175. begin
  1176. if (pd^.deftype=objectdef) and pobjectdef(pd)^.isclass then
  1177. begin
  1178. { default property }
  1179. propsym:=search_default_property(pobjectdef(pd));
  1180. if not(assigned(propsym)) then
  1181. begin
  1182. disposetree(p1);
  1183. p1:=genzeronode(errorn);
  1184. again:=false;
  1185. message(parser_e_no_default_property_available);
  1186. end
  1187. else
  1188. handle_propertysym(propsym,propsym^.owner,p1,pd);
  1189. end
  1190. else
  1191. begin
  1192. consume(LECKKLAMMER);
  1193. repeat
  1194. case pd^.deftype of
  1195. pointerdef:
  1196. begin
  1197. p2:=comp_expr(true);
  1198. p1:=gennode(vecn,p1,p2);
  1199. pd:=ppointerdef(pd)^.definition;
  1200. end;
  1201. stringdef : begin
  1202. p2:=comp_expr(true);
  1203. p1:=gennode(vecn,p1,p2);
  1204. pd:=cchardef
  1205. end;
  1206. arraydef : begin
  1207. p2:=comp_expr(true);
  1208. { support SEG:OFS for go32v2 Mem[] }
  1209. if (target_info.target=target_i386_go32v2) and
  1210. (p1^.treetype=loadn) and
  1211. assigned(p1^.symtableentry) and
  1212. assigned(p1^.symtableentry^.owner^.name) and
  1213. (p1^.symtableentry^.owner^.name^='SYSTEM') and
  1214. ((p1^.symtableentry^.name='MEM') or
  1215. (p1^.symtableentry^.name='MEMW') or
  1216. (p1^.symtableentry^.name='MEML')) then
  1217. begin
  1218. if (token=COLON) then
  1219. begin
  1220. consume(COLON);
  1221. p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
  1222. p2:=comp_expr(true);
  1223. p2:=gennode(addn,p2,p3);
  1224. p1:=gennode(vecn,p1,p2);
  1225. p1^.memseg:=true;
  1226. p1^.memindex:=true;
  1227. end
  1228. else
  1229. begin
  1230. p1:=gennode(vecn,p1,p2);
  1231. p1^.memindex:=true;
  1232. end;
  1233. end
  1234. else
  1235. p1:=gennode(vecn,p1,p2);
  1236. pd:=parraydef(pd)^.definition;
  1237. end;
  1238. else
  1239. begin
  1240. Message(cg_e_invalid_qualifier);
  1241. disposetree(p1);
  1242. p1:=genzeronode(errorn);
  1243. again:=false;
  1244. end;
  1245. end;
  1246. if token=COMMA then
  1247. consume(COMMA)
  1248. else
  1249. break;
  1250. until false;
  1251. consume(RECKKLAMMER);
  1252. end;
  1253. end;
  1254. POINT : begin
  1255. consume(POINT);
  1256. if (pd^.deftype=pointerdef) and
  1257. (m_autoderef in aktmodeswitches) then
  1258. begin
  1259. p1:=gensinglenode(derefn,p1);
  1260. pd:=ppointerdef(pd)^.definition;
  1261. end;
  1262. case pd^.deftype of
  1263. recorddef:
  1264. begin
  1265. sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
  1266. if sym=nil then
  1267. begin
  1268. Message1(sym_e_illegal_field,pattern);
  1269. disposetree(p1);
  1270. p1:=genzeronode(errorn);
  1271. end
  1272. else
  1273. begin
  1274. p1:=gensubscriptnode(sym,p1);
  1275. pd:=sym^.definition;
  1276. end;
  1277. consume(ID);
  1278. end;
  1279. classrefdef:
  1280. begin
  1281. classh:=pobjectdef(pclassrefdef(pd)^.definition);
  1282. sym:=nil;
  1283. while assigned(classh) do
  1284. begin
  1285. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1286. srsymtable:=classh^.publicsyms;
  1287. if assigned(sym) then
  1288. break;
  1289. classh:=classh^.childof;
  1290. end;
  1291. consume(ID);
  1292. do_member_read(getaddr,sym,p1,pd,again);
  1293. end;
  1294. objectdef:
  1295. begin
  1296. classh:=pobjectdef(pd);
  1297. sym:=nil;
  1298. store_static:=allow_only_static;
  1299. allow_only_static:=false;
  1300. while assigned(classh) do
  1301. begin
  1302. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1303. srsymtable:=classh^.publicsyms;
  1304. if assigned(sym) then
  1305. break;
  1306. classh:=classh^.childof;
  1307. end;
  1308. allow_only_static:=store_static;
  1309. consume(ID);
  1310. do_member_read(getaddr,sym,p1,pd,again);
  1311. end;
  1312. pointerdef:
  1313. begin
  1314. Message(cg_e_invalid_qualifier);
  1315. if ppointerdef(pd)^.definition^.deftype in [recorddef,objectdef,classrefdef] then
  1316. Message(parser_h_maybe_deref_caret_missing);
  1317. end;
  1318. else
  1319. begin
  1320. Message(cg_e_invalid_qualifier);
  1321. disposetree(p1);
  1322. p1:=genzeronode(errorn);
  1323. end;
  1324. end;
  1325. end;
  1326. else
  1327. begin
  1328. { is this a procedure variable ? }
  1329. if assigned(pd) then
  1330. begin
  1331. if (pd^.deftype=procvardef) then
  1332. begin
  1333. if getprocvar and is_equal(pd,getprocvardef) then
  1334. again:=false
  1335. else
  1336. if (token=LKLAMMER) or
  1337. ((pprocvardef(pd)^.para1=nil) and
  1338. (not((token in [ASSIGNMENT,UNEQUAL,EQUAL]))) and
  1339. (not afterassignment) and
  1340. (not in_args)) then
  1341. begin
  1342. { do this in a strange way }
  1343. { it's not a clean solution }
  1344. p2:=p1;
  1345. p1:=gencallnode(nil,nil);
  1346. p1^.right:=p2;
  1347. p1^.unit_specific:=unit_specific;
  1348. p1^.symtableprocentry:=pprocsym(sym);
  1349. if token=LKLAMMER then
  1350. begin
  1351. consume(LKLAMMER);
  1352. p1^.left:=parse_paras(false,false);
  1353. consume(RKLAMMER);
  1354. end;
  1355. pd:=pprocvardef(pd)^.retdef;
  1356. { proc():= is never possible }
  1357. if token=ASSIGNMENT then
  1358. begin
  1359. Message(cg_e_illegal_expression);
  1360. p1:=genzeronode(errorn);
  1361. again:=false;
  1362. end;
  1363. p1^.resulttype:=pd;
  1364. end
  1365. else
  1366. again:=false;
  1367. p1^.resulttype:=pd;
  1368. end
  1369. else
  1370. again:=false;
  1371. end
  1372. else
  1373. again:=false;
  1374. end;
  1375. end;
  1376. check_tokenpos;
  1377. end; { while again }
  1378. end;
  1379. {---------------------------------------------
  1380. Factor (Main)
  1381. ---------------------------------------------}
  1382. begin
  1383. oldp1:=nil;
  1384. p1:=nil;
  1385. filepos:=tokenpos;
  1386. if token=ID then
  1387. begin
  1388. factor_read_id;
  1389. { handle post fix operators }
  1390. postfixoperators;
  1391. end
  1392. else
  1393. case token of
  1394. _NEW : begin
  1395. consume(_NEW);
  1396. consume(LKLAMMER);
  1397. {allow_type:=true;}
  1398. p1:=factor(false);
  1399. {allow_type:=false;}
  1400. if p1^.treetype<>typen then
  1401. begin
  1402. Message(type_e_type_id_expected);
  1403. disposetree(p1);
  1404. pd:=generrordef;
  1405. end
  1406. else
  1407. pd:=p1^.typenodetype;
  1408. pd2:=pd;
  1409. if (pd^.deftype<>pointerdef) then
  1410. Message(type_e_pointer_type_expected)
  1411. else if {(ppointerdef(pd)^.definition^.deftype<>objectdef)}
  1412. token=RKLAMMER then
  1413. begin
  1414. if (ppointerdef(pd)^.definition^.deftype=objectdef) and
  1415. ((pobjectdef(ppointerdef(pd)^.definition)^.options and oo_hasvmt) <> 0) then
  1416. Message(parser_w_use_extended_syntax_for_objects);
  1417. p1:=gensinglenode(newn,nil);
  1418. p1^.resulttype:=pd2;
  1419. consume(RKLAMMER);
  1420. (*Message(parser_e_pointer_to_class_expected);
  1421. { if an error occurs, read til the end of
  1422. the new statement }
  1423. p1:=genzeronode(errorn);
  1424. l:=1;
  1425. while true do
  1426. begin
  1427. case token of
  1428. LKLAMMER : inc(l);
  1429. RKLAMMER : dec(l);
  1430. end;
  1431. consume(token);
  1432. if l=0 then
  1433. break;
  1434. end;*)
  1435. end
  1436. else
  1437. begin
  1438. disposetree(p1);
  1439. p1:=genzeronode(hnewn);
  1440. p1^.resulttype:=ppointerdef(pd)^.definition;
  1441. consume(COMMA);
  1442. afterassignment:=false;
  1443. { determines the current object defintion }
  1444. classh:=pobjectdef(ppointerdef(pd)^.definition);
  1445. { check for an abstract class }
  1446. if (classh^.options and oo_is_abstract)<>0 then
  1447. Message(sym_e_no_instance_of_abstract_object);
  1448. { search the constructor also in the symbol tables of
  1449. the parents }
  1450. { no constructor found }
  1451. sym:=nil;
  1452. while assigned(classh) do
  1453. begin
  1454. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1455. srsymtable:=classh^.publicsyms;
  1456. if assigned(sym) then
  1457. break;
  1458. classh:=classh^.childof;
  1459. end;
  1460. consume(ID);
  1461. do_member_read(false,sym,p1,pd,again);
  1462. if (p1^.treetype<>calln) or
  1463. (assigned(p1^.procdefinition) and
  1464. ((p1^.procdefinition^.options and poconstructor)=0)) then
  1465. Message(parser_e_expr_have_to_be_constructor_call);
  1466. p1:=gensinglenode(newn,p1);
  1467. { set the resulttype }
  1468. p1^.resulttype:=pd2;
  1469. consume(RKLAMMER);
  1470. end;
  1471. end;
  1472. _SELF : begin
  1473. again:=true;
  1474. consume(_SELF);
  1475. if not assigned(procinfo._class) then
  1476. begin
  1477. p1:=genzeronode(errorn);
  1478. pd:=generrordef;
  1479. again:=false;
  1480. Message(parser_e_self_not_in_method);
  1481. end
  1482. else
  1483. begin
  1484. if (aktprocsym^.definition^.options and poclassmethod)<>0 then
  1485. begin
  1486. { self in class methods is a class reference type }
  1487. pd:=new(pclassrefdef,init(procinfo._class));
  1488. p1:=genselfnode(pd);
  1489. p1^.resulttype:=pd;
  1490. end
  1491. else
  1492. begin
  1493. p1:=genselfnode(procinfo._class);
  1494. p1^.resulttype:=procinfo._class;
  1495. end;
  1496. pd:=p1^.resulttype;
  1497. postfixoperators;
  1498. end;
  1499. end;
  1500. _INHERITED : begin
  1501. again:=true;
  1502. consume(_INHERITED);
  1503. if assigned(procinfo._class) then
  1504. begin
  1505. classh:=procinfo._class^.childof;
  1506. while assigned(classh) do
  1507. begin
  1508. srsymtable:=pobjectdef(classh)^.publicsyms;
  1509. sym:=pvarsym(srsymtable^.search(pattern));
  1510. if assigned(sym) then
  1511. begin
  1512. p1:=genzeronode(typen);
  1513. p1^.resulttype:=classh;
  1514. pd:=p1^.resulttype;
  1515. consume(ID);
  1516. do_member_read(false,sym,p1,pd,again);
  1517. break;
  1518. end;
  1519. classh:=classh^.childof;
  1520. end;
  1521. if classh=nil then
  1522. begin
  1523. Message1(sym_e_id_no_member,pattern);
  1524. again:=false;
  1525. pd:=generrordef;
  1526. p1:=genzeronode(errorn);
  1527. end;
  1528. end
  1529. else
  1530. begin
  1531. Message(parser_e_generic_methods_only_in_methods);
  1532. again:=false;
  1533. pd:=generrordef;
  1534. p1:=genzeronode(errorn);
  1535. end;
  1536. postfixoperators;
  1537. end;
  1538. INTCONST : begin
  1539. valint(pattern,l,code);
  1540. if code<>0 then
  1541. begin
  1542. val(pattern,d,code);
  1543. if code<>0 then
  1544. begin
  1545. Message(cg_e_invalid_integer);
  1546. consume(INTCONST);
  1547. l:=1;
  1548. p1:=genordinalconstnode(l,s32bitdef);
  1549. end
  1550. else
  1551. begin
  1552. consume(INTCONST);
  1553. p1:=genrealconstnode(d,bestrealdef^);
  1554. end;
  1555. end
  1556. else
  1557. begin
  1558. consume(INTCONST);
  1559. p1:=genordinalconstnode(l,s32bitdef);
  1560. end;
  1561. end;
  1562. REALNUMBER : begin
  1563. val(pattern,d,code);
  1564. if code<>0 then
  1565. begin
  1566. Message(parser_e_error_in_real);
  1567. d:=1.0;
  1568. end;
  1569. consume(REALNUMBER);
  1570. p1:=genrealconstnode(d,bestrealdef^);
  1571. end;
  1572. _STRING : begin
  1573. pd:=stringtype;
  1574. { STRING can be also a type cast }
  1575. if token=LKLAMMER then
  1576. begin
  1577. consume(LKLAMMER);
  1578. p1:=comp_expr(true);
  1579. consume(RKLAMMER);
  1580. p1:=gentypeconvnode(p1,pd);
  1581. p1^.explizit:=true;
  1582. { handle postfix operators here e.g. string(a)[10] }
  1583. again:=true;
  1584. postfixoperators;
  1585. end
  1586. else
  1587. p1:=gentypenode(pd);
  1588. end;
  1589. _FILE : begin
  1590. pd:=cfiledef;
  1591. consume(_FILE);
  1592. { FILE can be also a type cast }
  1593. if token=LKLAMMER then
  1594. begin
  1595. consume(LKLAMMER);
  1596. p1:=comp_expr(true);
  1597. consume(RKLAMMER);
  1598. p1:=gentypeconvnode(p1,pd);
  1599. p1^.explizit:=true;
  1600. { handle postfix operators here e.g. string(a)[10] }
  1601. again:=true;
  1602. postfixoperators;
  1603. end
  1604. else
  1605. p1:=gentypenode(pd);
  1606. end;
  1607. CSTRING : begin
  1608. p1:=genstringconstnode(pattern);
  1609. consume(CSTRING);
  1610. end;
  1611. CCHAR : begin
  1612. p1:=genordinalconstnode(ord(pattern[1]),cchardef);
  1613. consume(CCHAR);
  1614. end;
  1615. KLAMMERAFFE : begin
  1616. consume(KLAMMERAFFE);
  1617. p1:=factor(true);
  1618. p1:=gensinglenode(addrn,p1);
  1619. end;
  1620. LKLAMMER : begin
  1621. consume(LKLAMMER);
  1622. p1:=comp_expr(true);
  1623. consume(RKLAMMER);
  1624. { it's not a good solution }
  1625. { but (a+b)^ makes some problems }
  1626. if token in [CARET,POINT,LECKKLAMMER] then
  1627. begin
  1628. { we need the resulttype }
  1629. { of the expression in pd }
  1630. do_firstpass(p1);
  1631. pd:=p1^.resulttype;
  1632. again:=true;
  1633. postfixoperators;
  1634. end;
  1635. end;
  1636. LECKKLAMMER : begin
  1637. consume(LECKKLAMMER);
  1638. p1:=factor_read_set;
  1639. consume(RECKKLAMMER);
  1640. end;
  1641. PLUS : begin
  1642. consume(PLUS);
  1643. p1:=factor(false);
  1644. end;
  1645. MINUS : begin
  1646. consume(MINUS);
  1647. p1:=factor(false);
  1648. p1:=gensinglenode(umminusn,p1);
  1649. end;
  1650. _NOT : begin
  1651. consume(_NOT);
  1652. p1:=factor(false);
  1653. p1:=gensinglenode(notn,p1);
  1654. end;
  1655. _TRUE : begin
  1656. consume(_TRUE);
  1657. p1:=genordinalconstnode(1,booldef);
  1658. end;
  1659. _FALSE : begin
  1660. consume(_FALSE);
  1661. p1:=genordinalconstnode(0,booldef);
  1662. end;
  1663. _NIL : begin
  1664. consume(_NIL);
  1665. p1:=genzeronode(niln);
  1666. end;
  1667. else
  1668. begin
  1669. p1:=genzeronode(errorn);
  1670. consume(token);
  1671. Message(cg_e_illegal_expression);
  1672. end;
  1673. end;
  1674. { generate error node if no node is created }
  1675. if not assigned(p1) then
  1676. p1:=genzeronode(errorn);
  1677. factor:=p1;
  1678. check_tokenpos;
  1679. end;
  1680. {****************************************************************************
  1681. Sub_Expr
  1682. ****************************************************************************}
  1683. type
  1684. Toperator_precedence=(opcompare,opaddition,opmultiply);
  1685. Ttok2nodeRec=record
  1686. tok : ttoken;
  1687. nod : ttreetyp;
  1688. end;
  1689. const
  1690. tok2nodes=23;
  1691. tok2node:array[1..tok2nodes] of ttok2noderec=(
  1692. (tok:PLUS ;nod:addn),
  1693. (tok:MINUS ;nod:subn),
  1694. (tok:STAR ;nod:muln),
  1695. (tok:SLASH ;nod:slashn),
  1696. (tok:EQUAL ;nod:equaln),
  1697. (tok:GT ;nod:gtn),
  1698. (tok:LT ;nod:ltn),
  1699. (tok:GTE ;nod:gten),
  1700. (tok:LTE ;nod:lten),
  1701. (tok:SYMDIF ;nod:symdifn),
  1702. (tok:STARSTAR;nod:starstarn),
  1703. (tok:CARET ;nod:caretn),
  1704. (tok:UNEQUAL ;nod:unequaln),
  1705. (tok:_AS ;nod:asn),
  1706. (tok:_IN ;nod:inn),
  1707. (tok:_IS ;nod:isn),
  1708. (tok:_OR ;nod:orn),
  1709. (tok:_AND ;nod:andn),
  1710. (tok:_DIV ;nod:divn),
  1711. (tok:_MOD ;nod:modn),
  1712. (tok:_SHL ;nod:shln),
  1713. (tok:_SHR ;nod:shrn),
  1714. (tok:_XOR ;nod:xorn)
  1715. );
  1716. operator_levels:array[Toperator_precedence] of set of Ttoken=
  1717. ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
  1718. [PLUS,MINUS,_OR,_XOR],
  1719. [CARET,SYMDIF,STARSTAR,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
  1720. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;
  1721. {Reads a subexpression while the operators are of the current precedence
  1722. level, or any higher level. Replaces the old term, simpl_expr and
  1723. simpl2_expr.}
  1724. var
  1725. low,high,mid : longint;
  1726. p1,p2 : Ptree;
  1727. oldt : Ttoken;
  1728. filepos : tfileposinfo;
  1729. begin
  1730. if pred_level=opmultiply then
  1731. p1:=factor(false)
  1732. else
  1733. p1:=sub_expr(succ(pred_level),true);
  1734. repeat
  1735. if (token in operator_levels[pred_level]) and
  1736. ((token<>EQUAL) or accept_equal) then
  1737. begin
  1738. oldt:=token;
  1739. filepos:=tokenpos;
  1740. consume(token);
  1741. if pred_level=opmultiply then
  1742. p2:=factor(false)
  1743. else
  1744. p2:=sub_expr(succ(pred_level),true);
  1745. low:=1;
  1746. high:=tok2nodes;
  1747. while (low<high) do
  1748. begin
  1749. mid:=(low+high+1) shr 1;
  1750. if oldt<tok2node[mid].tok then
  1751. high:=mid-1
  1752. else
  1753. low:=mid;
  1754. end;
  1755. if tok2node[high].tok=oldt then
  1756. p1:=gennode(tok2node[high].nod,p1,p2)
  1757. else
  1758. p1:=gennode(nothingn,p1,p2);
  1759. set_tree_filepos(p1,filepos);
  1760. end
  1761. else
  1762. break;
  1763. until false;
  1764. sub_expr:=p1;
  1765. end;
  1766. procedure check_tp_procvar(var p : ptree);
  1767. var
  1768. p1 : ptree;
  1769. begin
  1770. if (m_tp_procvar in aktmodeswitches) and
  1771. (not afterassignment) and
  1772. (not in_args) and (p^.treetype=loadn) then
  1773. begin
  1774. { support if procvar then for tp7 and many other expression like this }
  1775. firstpass(p);
  1776. if p^.resulttype^.deftype=procvardef then
  1777. begin
  1778. p1:=gencallnode(nil,nil);
  1779. p1^.right:=p;
  1780. p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
  1781. firstpass(p1);
  1782. p:=p1;
  1783. end;
  1784. end;
  1785. end;
  1786. function comp_expr(accept_equal : boolean):Ptree;
  1787. var
  1788. oldafterassignment : boolean;
  1789. p1 : ptree;
  1790. begin
  1791. oldafterassignment:=afterassignment;
  1792. afterassignment:=true;
  1793. p1:=sub_expr(opcompare,accept_equal);
  1794. afterassignment:=oldafterassignment;
  1795. if (m_tp_procvar in aktmodeswitches) then
  1796. check_tp_procvar(p1);
  1797. comp_expr:=p1;
  1798. end;
  1799. function expr : ptree;
  1800. var
  1801. p1,p2 : ptree;
  1802. oldafterassignment : boolean;
  1803. oldp1 : ptree;
  1804. filepos : tfileposinfo;
  1805. begin
  1806. oldafterassignment:=afterassignment;
  1807. p1:=sub_expr(opcompare,true);
  1808. filepos:=tokenpos;
  1809. if (m_tp_procvar in aktmodeswitches) and
  1810. (token<>ASSIGNMENT) then
  1811. check_tp_procvar(p1);
  1812. if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  1813. afterassignment:=true;
  1814. oldp1:=p1;
  1815. case token of
  1816. POINTPOINT : begin
  1817. consume(POINTPOINT);
  1818. p2:=sub_expr(opcompare,true);
  1819. p1:=gennode(rangen,p1,p2);
  1820. end;
  1821. ASSIGNMENT : begin
  1822. consume(ASSIGNMENT);
  1823. { avoid a firstpass of a procedure if
  1824. it must be assigned to a procvar }
  1825. { should be recursive for a:=b:=c !!! }
  1826. if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
  1827. begin
  1828. getprocvar:=true;
  1829. getprocvardef:=pprocvardef(p1^.resulttype);
  1830. end;
  1831. p2:=sub_expr(opcompare,true);
  1832. if getprocvar and (p2^.treetype=calln) then
  1833. handle_procvar(getprocvardef,p2);
  1834. { also allow p:= proc(t); !! (PM) }
  1835. if getprocvar and (p2^.treetype=typeconvn) and
  1836. (p2^.left^.treetype=calln) then
  1837. handle_procvar(getprocvardef,p2^.left);
  1838. getprocvar:=false;
  1839. p1:=gennode(assignn,p1,p2);
  1840. end;
  1841. { this is the code for C like assignements }
  1842. { from an improvement of Peter Schaefer }
  1843. _PLUSASN : begin
  1844. consume(_PLUSASN );
  1845. p2:=sub_expr(opcompare,true);
  1846. p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
  1847. { was first
  1848. p1:=gennode(assignn,p1,gennode(addn,p1,p2));
  1849. but disposetree assumes that we have a real
  1850. *** tree *** }
  1851. end;
  1852. _MINUSASN : begin
  1853. consume(_MINUSASN );
  1854. p2:=sub_expr(opcompare,true);
  1855. p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
  1856. end;
  1857. _STARASN : begin
  1858. consume(_STARASN );
  1859. p2:=sub_expr(opcompare,true);
  1860. p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
  1861. end;
  1862. _SLASHASN : begin
  1863. consume(_SLASHASN );
  1864. p2:=sub_expr(opcompare,true);
  1865. p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
  1866. end;
  1867. end;
  1868. afterassignment:=oldafterassignment;
  1869. if p1<>oldp1 then
  1870. set_tree_filepos(p1,filepos);
  1871. expr:=p1;
  1872. end;
  1873. function get_intconst:longint;
  1874. {Reads an expression, tries to evalute it and check if it is an integer
  1875. constant. Then the constant is returned.}
  1876. var
  1877. p:Ptree;
  1878. begin
  1879. p:=comp_expr(true);
  1880. do_firstpass(p);
  1881. if not codegenerror then
  1882. begin
  1883. if (p^.treetype<>ordconstn) and
  1884. (p^.resulttype^.deftype=orddef) and
  1885. not(Porddef(p^.resulttype)^.typ in [uvoid,uchar,bool8bit,bool16bit,bool32bit]) then
  1886. Message(cg_e_illegal_expression)
  1887. else
  1888. get_intconst:=p^.value;
  1889. end;
  1890. disposetree(p);
  1891. end;
  1892. function get_stringconst:string;
  1893. {Reads an expression, tries to evaluate it and checks if it is a string
  1894. constant. Then the constant is returned.}
  1895. var
  1896. p:Ptree;
  1897. begin
  1898. get_stringconst:='';
  1899. p:=comp_expr(true);
  1900. do_firstpass(p);
  1901. if p^.treetype<>stringconstn then
  1902. begin
  1903. if (p^.treetype=ordconstn) and is_char(p^.resulttype) then
  1904. get_stringconst:=char(p^.value)
  1905. else
  1906. Message(cg_e_illegal_expression);
  1907. end
  1908. else
  1909. get_stringconst:=strpas(p^.value_str);
  1910. disposetree(p);
  1911. end;
  1912. end.
  1913. {
  1914. $Log$
  1915. Revision 1.112 1999-06-02 22:44:11 pierre
  1916. * previous wrong log corrected
  1917. Revision 1.111 1999/06/02 22:25:43 pierre
  1918. * changed $ifdef FPC @ into $ifndef TP
  1919. * changes for correct procvar handling under tp mode
  1920. Revision 1.110 1999/06/01 19:27:55 peter
  1921. * better checks for procvar and methodpointer
  1922. Revision 1.109 1999/05/27 19:44:46 peter
  1923. * removed oldasm
  1924. * plabel -> pasmlabel
  1925. * -a switches to source writing automaticly
  1926. * assembler readers OOPed
  1927. * asmsymbol automaticly external
  1928. * jumptables and other label fixes for asm readers
  1929. Revision 1.108 1999/05/18 14:15:54 peter
  1930. * containsself fixes
  1931. * checktypes()
  1932. Revision 1.107 1999/05/18 09:52:18 peter
  1933. * procedure of object and addrn fixes
  1934. Revision 1.106 1999/05/16 17:06:31 peter
  1935. * remove firstcallparan which looks obsolete
  1936. Revision 1.105 1999/05/12 22:36:09 florian
  1937. * override isn't allowed in objects!
  1938. Revision 1.104 1999/05/07 10:35:23 florian
  1939. * first fix for a problem with method pointer properties, still doesn't work
  1940. with WITH
  1941. Revision 1.103 1999/05/06 21:40:16 peter
  1942. * fixed crash
  1943. Revision 1.101 1999/05/06 09:05:21 peter
  1944. * generic write_float and str_float
  1945. * fixed constant float conversions
  1946. Revision 1.100 1999/05/04 21:44:57 florian
  1947. * changes to compile it with Delphi 4.0
  1948. Revision 1.99 1999/05/01 13:24:31 peter
  1949. * merged nasm compiler
  1950. * old asm moved to oldasm/
  1951. Revision 1.98 1999/04/26 18:29:56 peter
  1952. * farpointerdef moved into pointerdef.is_far
  1953. Revision 1.97 1999/04/19 09:27:48 peter
  1954. * removed my property fix
  1955. Revision 1.96 1999/04/19 09:13:47 peter
  1956. * class property without write support
  1957. Revision 1.95 1999/04/19 06:10:08 florian
  1958. * property problem fixed: a propertysym is only a write
  1959. access if it is followed by a assignment token
  1960. Revision 1.94 1999/04/17 13:12:17 peter
  1961. * addr() internal
  1962. Revision 1.93 1999/04/15 09:00:08 peter
  1963. * fixed property write
  1964. Revision 1.92 1999/04/08 20:59:43 florian
  1965. * fixed problem with default properties which are a class
  1966. * case bug (from the mailing list with -O2) fixed, the
  1967. distance of the case labels can be greater than the positive
  1968. range of a longint => it is now a dword for fpc
  1969. Revision 1.91 1999/04/06 11:21:56 peter
  1970. * more use of ttoken
  1971. Revision 1.90 1999/03/31 13:55:12 peter
  1972. * assembler inlining working for ag386bin
  1973. Revision 1.89 1999/03/26 00:05:36 peter
  1974. * released valintern
  1975. + deffile is now removed when compiling is finished
  1976. * ^( compiles now correct
  1977. + static directive
  1978. * shrd fixed
  1979. Revision 1.88 1999/03/24 23:17:15 peter
  1980. * fixed bugs 212,222,225,227,229,231,233
  1981. Revision 1.87 1999/03/16 17:52:52 jonas
  1982. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  1983. * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  1984. * in cgai386: also small fixes to emitrangecheck
  1985. Revision 1.86 1999/03/04 13:55:44 pierre
  1986. * some m68k fixes (still not compilable !)
  1987. * new(tobj) does not give warning if tobj has no VMT !
  1988. Revision 1.85 1999/02/22 15:09:39 florian
  1989. * behaviaor of PROTECTED and PRIVATE fixed, works now like TP/Delphi
  1990. Revision 1.84 1999/02/22 02:15:26 peter
  1991. * updates for ag386bin
  1992. Revision 1.83 1999/02/11 09:46:25 pierre
  1993. * fix for normal method calls inside static methods :
  1994. WARNING there were both parser and codegen errors !!
  1995. added static_call boolean to calln tree
  1996. Revision 1.82 1999/01/28 14:06:47 florian
  1997. * small fix for method pointers
  1998. * found the annoying strpas bug, mainly nested call to type cast which
  1999. use ansistrings crash
  2000. Revision 1.81 1999/01/27 00:13:55 florian
  2001. * "procedure of object"-stuff fixed
  2002. Revision 1.80 1999/01/21 16:41:01 pierre
  2003. * fix for constructor inside with statements
  2004. Revision 1.79 1998/12/30 22:15:48 peter
  2005. + farpointer type
  2006. * absolutesym now also stores if its far
  2007. Revision 1.78 1998/12/11 00:03:32 peter
  2008. + globtype,tokens,version unit splitted from globals
  2009. Revision 1.77 1998/12/04 10:18:09 florian
  2010. * some stuff for procedures of object added
  2011. * bug with overridden virtual constructors fixed (reported by Italo Gomes)
  2012. Revision 1.76 1998/11/27 14:50:40 peter
  2013. + open strings, $P switch support
  2014. Revision 1.75 1998/11/25 19:12:51 pierre
  2015. * var:=new(pointer_type) support added
  2016. Revision 1.74 1998/11/13 10:18:11 peter
  2017. + nil constants
  2018. Revision 1.73 1998/11/05 12:02:52 peter
  2019. * released useansistring
  2020. * removed -Sv, its now available in fpc modes
  2021. Revision 1.72 1998/11/04 10:11:41 peter
  2022. * ansistring fixes
  2023. Revision 1.71 1998/10/22 23:57:29 peter
  2024. * fixed filedef for typenodetype
  2025. Revision 1.70 1998/10/21 15:12:54 pierre
  2026. * bug fix for IOCHECK inside a procedure with iocheck modifier
  2027. * removed the GPF for unexistant overloading
  2028. (firstcall was called with procedinition=nil !)
  2029. * changed typen to what Florian proposed
  2030. gentypenode(p : pdef) sets the typenodetype field
  2031. and resulttype is only set if inside bt_type block !
  2032. Revision 1.69 1998/10/20 15:10:19 pierre
  2033. * type ptree only allowed inside expression
  2034. if following sizeof typeof low high or as first arg of new !!
  2035. Revision 1.68 1998/10/20 11:15:44 pierre
  2036. * calling of private method allowed inside child object method
  2037. Revision 1.67 1998/10/19 08:54:57 pierre
  2038. * wrong stabs info corrected once again !!
  2039. + variable vmt offset with vmt field only if required
  2040. implemented now !!!
  2041. Revision 1.66 1998/10/15 15:13:28 pierre
  2042. + added oo_hasconstructor and oo_hasdestructor
  2043. for objects options
  2044. Revision 1.65 1998/10/13 13:10:24 peter
  2045. * new style for m68k/i386 infos and enums
  2046. Revision 1.64 1998/10/12 12:20:55 pierre
  2047. + added tai_const_symbol_offset
  2048. for r : pointer = @var.field;
  2049. * better message for different arg names on implementation
  2050. of function
  2051. Revision 1.63 1998/10/12 10:28:30 florian
  2052. + auto dereferencing of pointers to structured types in delphi mode
  2053. Revision 1.62 1998/10/12 10:05:41 peter
  2054. * fixed mem leak with arrayconstrutor
  2055. Revision 1.61 1998/10/05 13:57:15 peter
  2056. * crash preventions
  2057. Revision 1.60 1998/10/05 12:32:46 peter
  2058. + assert() support
  2059. Revision 1.59 1998/10/01 14:56:24 peter
  2060. * crash preventions
  2061. Revision 1.58 1998/09/30 07:40:35 florian
  2062. * better error recovering
  2063. Revision 1.57 1998/09/28 16:18:16 florian
  2064. * two fixes to get ansi strings work
  2065. Revision 1.56 1998/09/26 17:45:36 peter
  2066. + idtoken and only one token table
  2067. Revision 1.55 1998/09/24 23:49:10 peter
  2068. + aktmodeswitches
  2069. Revision 1.54 1998/09/23 15:46:39 florian
  2070. * problem with with and classes fixed
  2071. Revision 1.53 1998/09/23 09:58:54 peter
  2072. * first working array of const things
  2073. Revision 1.52 1998/09/20 09:38:45 florian
  2074. * hasharray for defs fixed
  2075. * ansistring code generation corrected (init/final, assignement)
  2076. Revision 1.51 1998/09/18 16:03:43 florian
  2077. * some changes to compile with Delphi
  2078. Revision 1.50 1998/09/17 13:41:18 pierre
  2079. sizeof(TPOINT) problem
  2080. Revision 1.49.2.1 1998/09/17 08:42:31 pierre
  2081. TPOINT sizeof fix
  2082. Revision 1.49 1998/09/09 11:50:53 pierre
  2083. * forward def are not put in record or objects
  2084. + added check for forwards also in record and objects
  2085. * dummy parasymtable for unit initialization removed from
  2086. symtable stack
  2087. Revision 1.48 1998/09/07 22:25:53 peter
  2088. * fixed str(boolean,string) which was allowed
  2089. * fixed write(' ':<int expression>) only constants where allowed :(
  2090. Revision 1.47 1998/09/07 18:46:10 peter
  2091. * update smartlinking, uses getdatalabel
  2092. * renamed ptree.value vars to value_str,value_real,value_set
  2093. Revision 1.46 1998/09/04 08:42:03 peter
  2094. * updated some error messages
  2095. Revision 1.45 1998/09/01 17:39:49 peter
  2096. + internal constant functions
  2097. Revision 1.44 1998/08/28 10:54:24 peter
  2098. * fixed smallset generation from elements, it has never worked before!
  2099. Revision 1.43 1998/08/23 16:07:24 florian
  2100. * internalerror with mod/div fixed
  2101. Revision 1.42 1998/08/21 14:08:50 pierre
  2102. + TEST_FUNCRET now default (old code removed)
  2103. works also for m68k (at least compiles)
  2104. Revision 1.41 1998/08/20 21:36:39 peter
  2105. * fixed 'with object do' bug
  2106. Revision 1.40 1998/08/20 09:26:41 pierre
  2107. + funcret setting in underproc testing
  2108. compile with _dTEST_FUNCRET
  2109. Revision 1.39 1998/08/18 16:48:48 pierre
  2110. * bug for -So proc assignment to p^rocvar fixed
  2111. Revision 1.38 1998/08/18 14:17:09 pierre
  2112. * bug about assigning the return value of a function to
  2113. a procvar fixed : warning
  2114. assigning a proc to a procvar need @ in FPC mode !!
  2115. * missing file/line info restored
  2116. Revision 1.37 1998/08/18 09:24:43 pierre
  2117. * small warning position bug fixed
  2118. * support_mmx switches splitting was missing
  2119. * rhide error and warning output corrected
  2120. Revision 1.36 1998/08/15 16:50:29 peter
  2121. * fixed proc()=expr which was not allowed anymore by my previous fix
  2122. Revision 1.35 1998/08/14 18:18:46 peter
  2123. + dynamic set contruction
  2124. * smallsets are now working (always longint size)
  2125. Revision 1.34 1998/08/13 11:00:12 peter
  2126. * fixed procedure<>procedure construct
  2127. Revision 1.33 1998/08/11 15:31:39 peter
  2128. * write extended to ppu file
  2129. * new version 0.99.7
  2130. Revision 1.32 1998/08/11 14:05:32 peter
  2131. * fixed sizeof(array of char)
  2132. Revision 1.31 1998/08/10 14:50:11 peter
  2133. + localswitches, moduleswitches, globalswitches splitting
  2134. Revision 1.30 1998/07/28 21:52:54 florian
  2135. + implementation of raise and try..finally
  2136. + some misc. exception stuff
  2137. Revision 1.29 1998/07/27 21:57:13 florian
  2138. * fix to allow tv like stream registration:
  2139. @tmenu.load doesn't work if load had parameters or if load was only
  2140. declared in an anchestor class of tmenu
  2141. Revision 1.28 1998/07/14 21:46:51 peter
  2142. * updated messages file
  2143. Revision 1.27 1998/06/25 14:04:23 peter
  2144. + internal inc/dec
  2145. Revision 1.26 1998/06/09 16:01:46 pierre
  2146. + added procedure directive parsing for procvars
  2147. (accepted are popstack cdecl and pascal)
  2148. + added C vars with the following syntax
  2149. var C calias 'true_c_name';(can be followed by external)
  2150. reason is that you must add the Cprefix
  2151. which is target dependent
  2152. Revision 1.25 1998/06/05 14:37:33 pierre
  2153. * fixes for inline for operators
  2154. * inline procedure more correctly restricted
  2155. Revision 1.24 1998/06/04 23:51:52 peter
  2156. * m68k compiles
  2157. + .def file creation moved to gendef.pas so it could also be used
  2158. for win32
  2159. Revision 1.23 1998/06/04 09:55:40 pierre
  2160. * demangled name of procsym reworked to become independant of the mangling scheme
  2161. Revision 1.22 1998/06/02 17:03:03 pierre
  2162. * with node corrected for objects
  2163. * small bugs for SUPPORT_MMX fixed
  2164. Revision 1.21 1998/05/27 19:45:05 peter
  2165. * symtable.pas splitted into includefiles
  2166. * symtable adapted for $ifdef NEWPPU
  2167. Revision 1.20 1998/05/26 07:53:59 pierre
  2168. * bug fix for empty sets (nil pd was dereferenced )
  2169. Revision 1.19 1998/05/25 17:11:43 pierre
  2170. * firstpasscount bug fixed
  2171. now all is already set correctly the first time
  2172. under EXTDEBUG try -gp to skip all other firstpasses
  2173. it works !!
  2174. * small bug fixes
  2175. - for smallsets with -dTESTSMALLSET
  2176. - some warnings removed (by correcting code !)
  2177. Revision 1.18 1998/05/23 01:21:20 peter
  2178. + aktasmmode, aktoptprocessor, aktoutputformat
  2179. + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
  2180. + $LIBNAME to set the library name where the unit will be put in
  2181. * splitted cgi386 a bit (codeseg to large for bp7)
  2182. * nasm, tasm works again. nasm moved to ag386nsm.pas
  2183. Revision 1.17 1998/05/22 12:37:03 carl
  2184. * crash bugfix (patched msanually to main branch)
  2185. Revision 1.16 1998/05/21 19:33:32 peter
  2186. + better procedure directive handling and only one table
  2187. Revision 1.15 1998/05/20 09:42:35 pierre
  2188. + UseTokenInfo now default
  2189. * unit in interface uses and implementation uses gives error now
  2190. * only one error for unknown symbol (uses lastsymknown boolean)
  2191. the problem came from the label code !
  2192. + first inlined procedures and function work
  2193. (warning there might be allowed cases were the result is still wrong !!)
  2194. * UseBrower updated gives a global list of all position of all used symbols
  2195. with switch -gb
  2196. Revision 1.14 1998/05/11 13:07:56 peter
  2197. + $ifdef NEWPPU for the new ppuformat
  2198. + $define GDB not longer required
  2199. * removed all warnings and stripped some log comments
  2200. * no findfirst/findnext anymore to remove smartlink *.o files
  2201. Revision 1.13 1998/05/06 08:38:45 pierre
  2202. * better position info with UseTokenInfo
  2203. UseTokenInfo greatly simplified
  2204. + added check for changed tree after first time firstpass
  2205. (if we could remove all the cases were it happen
  2206. we could skip all firstpass if firstpasscount > 1)
  2207. Only with ExtDebug
  2208. Revision 1.12 1998/05/05 12:05:42 florian
  2209. * problems with properties fixed
  2210. * crash fixed: i:=l when i and l are undefined, was a problem with
  2211. implementation of private/protected
  2212. Revision 1.11 1998/05/04 11:22:26 florian
  2213. * problem with DOM solved: it crashes when accessing a property in a method
  2214. Revision 1.10 1998/05/01 16:38:45 florian
  2215. * handling of private and protected fixed
  2216. + change_keywords_to_tp implemented to remove
  2217. keywords which aren't supported by tp
  2218. * break and continue are now symbols of the system unit
  2219. + widestring, longstring and ansistring type released
  2220. Revision 1.9 1998/04/29 10:33:58 pierre
  2221. + added some code for ansistring (not complete nor working yet)
  2222. * corrected operator overloading
  2223. * corrected nasm output
  2224. + started inline procedures
  2225. + added starstarn : use ** for exponentiation (^ gave problems)
  2226. + started UseTokenInfo cond to get accurate positions
  2227. Revision 1.8 1998/04/14 23:27:03 florian
  2228. + exclude/include with constant second parameter added
  2229. Revision 1.7 1998/04/09 23:02:15 florian
  2230. * small problems solved to get remake3 work
  2231. Revision 1.6 1998/04/09 22:16:35 florian
  2232. * problem with previous REGALLOC solved
  2233. * improved property support
  2234. Revision 1.5 1998/04/08 10:26:09 florian
  2235. * correct error handling of virtual constructors
  2236. * problem with new type declaration handling fixed
  2237. Revision 1.4 1998/04/07 22:45:05 florian
  2238. * bug0092, bug0115 and bug0121 fixed
  2239. + packed object/class/array
  2240. Revision 1.3 1998/04/07 13:19:46 pierre
  2241. * bugfixes for reset_gdb_info
  2242. in MEM parsing for go32v2
  2243. better external symbol creation
  2244. support for rhgdb.exe (lowercase file names)
  2245. }