pexpr.pas 91 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467
  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. (m_tp_procvar in aktmodeswitches) and
  681. proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
  682. ,again,p1,pd);
  683. { now we know the real method e.g. we can check for }
  684. { a class method }
  685. if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
  686. Message(parser_e_only_class_methods_via_class_ref);
  687. end;
  688. varsym:
  689. begin
  690. if isclassref then
  691. Message(parser_e_only_class_methods_via_class_ref);
  692. if (sym^.properties and sp_static)<>0 then
  693. begin
  694. { static_name:=lower(srsymtable^.name^)+'_'+sym^.name;
  695. this is wrong for static field in with symtable (PM) }
  696. static_name:=lower(srsym^.owner^.name^)+'_'+sym^.name;
  697. getsym(static_name,true);
  698. disposetree(p1);
  699. p1:=genloadnode(pvarsym(srsym),srsymtable);
  700. end
  701. else
  702. p1:=gensubscriptnode(pvarsym(sym),p1);
  703. pd:=pvarsym(sym)^.definition;
  704. end;
  705. propertysym:
  706. begin
  707. if isclassref then
  708. Message(parser_e_only_class_methods_via_class_ref);
  709. handle_propertysym(sym,srsymtable,p1,pd);
  710. end;
  711. else internalerror(16);
  712. end;
  713. end;
  714. end;
  715. {****************************************************************************
  716. Factor
  717. ****************************************************************************}
  718. function factor(getaddr : boolean) : ptree;
  719. var
  720. l : longint;
  721. oldp1,
  722. p1,p2,p3 : ptree;
  723. code : integer;
  724. pd,pd2 : pdef;
  725. possible_error,
  726. unit_specific,
  727. again : boolean;
  728. sym : pvarsym;
  729. classh : pobjectdef;
  730. d : bestreal;
  731. static_name : string;
  732. propsym : ppropertysym;
  733. filepos : tfileposinfo;
  734. {---------------------------------------------
  735. Is_func_ret
  736. ---------------------------------------------}
  737. function is_func_ret(sym : psym) : boolean;
  738. var
  739. p : pprocinfo;
  740. storesymtablestack : psymtable;
  741. begin
  742. is_func_ret:=false;
  743. if (sym^.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0) then
  744. exit;
  745. p:=@procinfo;
  746. while system.assigned(p) do
  747. begin
  748. { is this an access to a function result ? }
  749. if assigned(p^.funcretsym) and
  750. ((pfuncretsym(sym)=p^.funcretsym) or
  751. ((pvarsym(sym)=opsym) and
  752. ((p^.flags and pi_operator)<>0))) and
  753. (p^.retdef<>pdef(voiddef)) and
  754. (token<>LKLAMMER) and
  755. (not ((m_tp in aktmodeswitches) and
  756. (afterassignment or in_args))) then
  757. begin
  758. p1:=genzeronode(funcretn);
  759. pd:=p^.retdef;
  760. p1^.funcretprocinfo:=p;
  761. p1^.retdef:=pd;
  762. is_func_ret:=true;
  763. exit;
  764. end;
  765. p:=p^.parent;
  766. end;
  767. { we must use the function call }
  768. if(sym^.typ=funcretsym) then
  769. begin
  770. storesymtablestack:=symtablestack;
  771. symtablestack:=srsymtable^.next;
  772. getsym(sym^.name,true);
  773. if srsym^.typ<>procsym then
  774. Message(cg_e_illegal_expression);
  775. symtablestack:=storesymtablestack;
  776. end;
  777. end;
  778. {---------------------------------------------
  779. Factor_read_id
  780. ---------------------------------------------}
  781. procedure factor_read_id;
  782. var
  783. pc : pchar;
  784. len : longint;
  785. begin
  786. { allow post fix operators }
  787. again:=true;
  788. if (m_result in aktmodeswitches) and
  789. (idtoken=_RESULT) and
  790. assigned(aktprocsym) and
  791. (procinfo.retdef<>pdef(voiddef)) then
  792. begin
  793. consume(ID);
  794. p1:=genzeronode(funcretn);
  795. pd:=procinfo.retdef;
  796. p1^.funcretprocinfo:=pointer(@procinfo);
  797. p1^.retdef:=pd;
  798. end
  799. else
  800. begin
  801. if lastsymknown then
  802. begin
  803. srsym:=lastsrsym;
  804. srsymtable:=lastsrsymtable;
  805. lastsymknown:=false;
  806. end
  807. else
  808. getsym(pattern,true);
  809. consume(ID);
  810. if not is_func_ret(srsym) then
  811. { else it's a normal symbol }
  812. begin
  813. { is it defined like UNIT.SYMBOL ? }
  814. if srsym^.typ=unitsym then
  815. begin
  816. consume(POINT);
  817. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  818. unit_specific:=true;
  819. consume(ID);
  820. end
  821. else
  822. unit_specific:=false;
  823. if not assigned(srsym) then
  824. Begin
  825. p1:=genzeronode(errorn);
  826. { try to clean up }
  827. pd:=generrordef;
  828. end
  829. else
  830. Begin
  831. { check semantics of private }
  832. if (srsym^.typ in [propertysym,procsym,varsym]) and
  833. (srsymtable^.symtabletype=objectsymtable) then
  834. begin
  835. if ((srsym^.properties and sp_private)<>0) and
  836. (pobjectdef(srsym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then
  837. Message(parser_e_cant_access_private_member);
  838. end;
  839. case srsym^.typ of
  840. absolutesym : begin
  841. p1:=genloadnode(pvarsym(srsym),srsymtable);
  842. pd:=pabsolutesym(srsym)^.definition;
  843. end;
  844. varsym : begin
  845. { are we in a class method ? }
  846. if (srsymtable^.symtabletype=objectsymtable) and
  847. assigned(aktprocsym) and
  848. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  849. Message(parser_e_only_class_methods);
  850. if (srsym^.properties and sp_static)<>0 then
  851. begin
  852. static_name:=lower(srsym^.owner^.name^)+'_'+srsym^.name;
  853. getsym(static_name,true);
  854. end;
  855. p1:=genloadnode(pvarsym(srsym),srsymtable);
  856. if pvarsym(srsym)^.is_valid=0 then
  857. begin
  858. p1^.is_first := true;
  859. { set special between first loaded until checked in firstpass }
  860. pvarsym(srsym)^.is_valid:=2;
  861. end;
  862. pd:=pvarsym(srsym)^.definition;
  863. end;
  864. typedconstsym : begin
  865. p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
  866. pd:=ptypedconstsym(srsym)^.definition;
  867. end;
  868. syssym : p1:=statement_syssym(psyssym(srsym)^.number,pd);
  869. typesym : begin
  870. pd:=ptypesym(srsym)^.definition;
  871. if not assigned(pd) then
  872. begin
  873. pd:=generrordef;
  874. again:=false;
  875. end
  876. else
  877. { if we read a type declaration }
  878. { we have to return the type and }
  879. { nothing else }
  880. if block_type=bt_type then
  881. begin
  882. p1:=gentypenode(pd);
  883. { here we can also set resulttype !! }
  884. p1^.resulttype:=pd;
  885. pd:=voiddef;
  886. end
  887. else { not type block }
  888. begin
  889. if token=LKLAMMER then
  890. begin
  891. consume(LKLAMMER);
  892. p1:=comp_expr(true);
  893. consume(RKLAMMER);
  894. p1:=gentypeconvnode(p1,pd);
  895. p1^.explizit:=true;
  896. end
  897. else { not LKLAMMER}
  898. if (token=POINT) and
  899. (pd^.deftype=objectdef) and
  900. not(pobjectdef(pd)^.isclass) then
  901. begin
  902. consume(POINT);
  903. if assigned(procinfo._class) then
  904. begin
  905. if procinfo._class^.isrelated(pobjectdef(pd)) then
  906. begin
  907. p1:=gentypenode(pd);
  908. p1^.resulttype:=pd;
  909. srsymtable:=pobjectdef(pd)^.publicsyms;
  910. sym:=pvarsym(srsymtable^.search(pattern));
  911. { search also in inherited methods }
  912. while sym=nil do
  913. begin
  914. pd:=pobjectdef(pd)^.childof;
  915. srsymtable:=pobjectdef(pd)^.publicsyms;
  916. sym:=pvarsym(srsymtable^.search(pattern));
  917. end;
  918. consume(ID);
  919. do_member_read(false,sym,p1,pd,again);
  920. end
  921. else
  922. begin
  923. Message(parser_e_no_super_class);
  924. pd:=generrordef;
  925. again:=false;
  926. end;
  927. end
  928. else
  929. begin
  930. { allows @TObject.Load }
  931. { also allows static methods and variables }
  932. p1:=genzeronode(typen);
  933. p1^.resulttype:=pd;
  934. { srsymtable:=pobjectdef(pd)^.publicsyms;
  935. sym:=pvarsym(srsymtable^.search(pattern)); }
  936. { TP allows also @TMenu.Load if Load is only }
  937. { defined in an anchestor class }
  938. sym:=pvarsym(search_class_member(pobjectdef(pd),pattern));
  939. if not assigned(sym) then
  940. Message1(sym_e_id_no_member,pattern)
  941. else if not(getaddr) and ((sym^.properties and sp_static)=0) then
  942. Message(sym_e_only_static_in_static)
  943. else
  944. begin
  945. consume(ID);
  946. do_member_read(getaddr,sym,p1,pd,again);
  947. end;
  948. end;
  949. end
  950. else
  951. begin
  952. { class reference ? }
  953. if (pd^.deftype=objectdef)
  954. and pobjectdef(pd)^.isclass then
  955. begin
  956. p1:=gentypenode(pd);
  957. p1^.resulttype:=pd;
  958. pd:=new(pclassrefdef,init(pd));
  959. p1:=gensinglenode(loadvmtn,p1);
  960. p1^.resulttype:=pd;
  961. end
  962. else
  963. begin
  964. { generate a type node }
  965. { (for typeof etc) }
  966. if allow_type then
  967. begin
  968. p1:=gentypenode(pd);
  969. { here we must use typenodetype explicitly !! PM
  970. p1^.resulttype:=pd; }
  971. pd:=voiddef;
  972. end
  973. else
  974. Message(parser_e_no_type_not_allowed_here);
  975. end;
  976. end;
  977. end;
  978. end;
  979. enumsym : begin
  980. p1:=genenumnode(penumsym(srsym));
  981. pd:=p1^.resulttype;
  982. end;
  983. constsym : begin
  984. case pconstsym(srsym)^.consttype of
  985. constint :
  986. p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
  987. conststring :
  988. begin
  989. len:=pconstsym(srsym)^.len;
  990. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  991. len:=255;
  992. getmem(pc,len+1);
  993. move(pchar(pconstsym(srsym)^.value)^,pc^,len);
  994. pc[len]:=#0;
  995. p1:=genpcharconstnode(pc,len);
  996. end;
  997. constchar :
  998. p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
  999. constreal :
  1000. p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^,bestrealdef^);
  1001. constbool :
  1002. p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
  1003. constset :
  1004. p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
  1005. psetdef(pconstsym(srsym)^.definition));
  1006. constord :
  1007. p1:=genordinalconstnode(pconstsym(srsym)^.value,
  1008. pconstsym(srsym)^.definition);
  1009. constnil :
  1010. p1:=genzeronode(niln);
  1011. end;
  1012. pd:=p1^.resulttype;
  1013. end;
  1014. procsym : begin
  1015. { are we in a class method ? }
  1016. possible_error:=(srsymtable^.symtabletype=objectsymtable) and
  1017. assigned(aktprocsym) and
  1018. ((aktprocsym^.definition^.options and poclassmethod)<>0);
  1019. p1:=gencallnode(pprocsym(srsym),srsymtable);
  1020. p1^.unit_specific:=unit_specific;
  1021. do_proc_call(getaddr or
  1022. (getprocvar and
  1023. (m_tp_procvar in aktmodeswitches) and
  1024. proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
  1025. again,p1,pd);
  1026. if possible_error and
  1027. ((p1^.procdefinition^.options and poclassmethod)=0) then
  1028. Message(parser_e_only_class_methods);
  1029. end;
  1030. propertysym : begin
  1031. { access to property in a method }
  1032. { are we in a class method ? }
  1033. if (srsymtable^.symtabletype=objectsymtable) and
  1034. assigned(aktprocsym) and
  1035. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  1036. Message(parser_e_only_class_methods);
  1037. { no method pointer }
  1038. p1:=nil;
  1039. handle_propertysym(srsym,srsymtable,p1,pd);
  1040. end;
  1041. errorsym : begin
  1042. p1:=genzeronode(errorn);
  1043. pd:=generrordef;
  1044. if token=LKLAMMER then
  1045. begin
  1046. consume(LKLAMMER);
  1047. parse_paras(false,false);
  1048. consume(RKLAMMER);
  1049. end;
  1050. end;
  1051. else
  1052. begin
  1053. p1:=genzeronode(errorn);
  1054. pd:=generrordef;
  1055. Message(cg_e_illegal_expression);
  1056. end;
  1057. end; { end case }
  1058. end;
  1059. end;
  1060. end;
  1061. end;
  1062. {---------------------------------------------
  1063. Factor_Read_Set
  1064. ---------------------------------------------}
  1065. { Read a set between [] }
  1066. function factor_read_set:ptree;
  1067. var
  1068. p1,
  1069. lastp,
  1070. buildp : ptree;
  1071. begin
  1072. buildp:=nil;
  1073. { be sure that a least one arrayconstructn is used, also for an
  1074. empty [] }
  1075. if token=RECKKLAMMER then
  1076. buildp:=gennode(arrayconstructn,nil,buildp)
  1077. else
  1078. begin
  1079. while true do
  1080. begin
  1081. p1:=comp_expr(true);
  1082. if token=POINTPOINT then
  1083. begin
  1084. consume(POINTPOINT);
  1085. p2:=comp_expr(true);
  1086. p1:=gennode(arrayconstructrangen,p1,p2);
  1087. end;
  1088. { insert at the end of the tree, to get the correct order }
  1089. if not assigned(buildp) then
  1090. begin
  1091. buildp:=gennode(arrayconstructn,p1,nil);
  1092. lastp:=buildp;
  1093. end
  1094. else
  1095. begin
  1096. lastp^.right:=gennode(arrayconstructn,p1,nil);
  1097. lastp:=lastp^.right;
  1098. end;
  1099. { there could be more elements }
  1100. if token=COMMA then
  1101. consume(COMMA)
  1102. else
  1103. break;
  1104. end;
  1105. end;
  1106. factor_read_set:=buildp;
  1107. end;
  1108. {---------------------------------------------
  1109. Helpers
  1110. ---------------------------------------------}
  1111. procedure check_tokenpos;
  1112. begin
  1113. if (p1<>oldp1) then
  1114. begin
  1115. if assigned(p1) then
  1116. set_tree_filepos(p1,filepos);
  1117. oldp1:=p1;
  1118. filepos:=tokenpos;
  1119. end;
  1120. end;
  1121. {---------------------------------------------
  1122. PostFixOperators
  1123. ---------------------------------------------}
  1124. procedure postfixoperators;
  1125. var
  1126. store_static : boolean;
  1127. { p1 and p2 must contain valid value_str }
  1128. begin
  1129. check_tokenpos;
  1130. while again do
  1131. begin
  1132. { prevent crashes with unknown types }
  1133. if not assigned(pd) then
  1134. begin
  1135. { try to recover }
  1136. repeat
  1137. case token of
  1138. CARET:
  1139. consume(CARET);
  1140. POINT:
  1141. begin
  1142. consume(POINT);
  1143. consume(ID);
  1144. end;
  1145. LECKKLAMMER:
  1146. begin
  1147. repeat
  1148. consume(token);
  1149. until token in [RECKKLAMMER,SEMICOLON];
  1150. end;
  1151. else
  1152. break;
  1153. end;
  1154. until false;
  1155. exit;
  1156. end;
  1157. { handle token }
  1158. case token of
  1159. CARET:
  1160. begin
  1161. consume(CARET);
  1162. if (pd^.deftype<>pointerdef) then
  1163. begin
  1164. { ^ as binary operator is a problem!!!! (FK) }
  1165. again:=false;
  1166. Message(cg_e_invalid_qualifier);
  1167. disposetree(p1);
  1168. p1:=genzeronode(errorn);
  1169. end
  1170. else
  1171. begin
  1172. p1:=gensinglenode(derefn,p1);
  1173. pd:=ppointerdef(pd)^.definition;
  1174. end;
  1175. end;
  1176. LECKKLAMMER:
  1177. begin
  1178. if (pd^.deftype=objectdef) and pobjectdef(pd)^.isclass then
  1179. begin
  1180. { default property }
  1181. propsym:=search_default_property(pobjectdef(pd));
  1182. if not(assigned(propsym)) then
  1183. begin
  1184. disposetree(p1);
  1185. p1:=genzeronode(errorn);
  1186. again:=false;
  1187. message(parser_e_no_default_property_available);
  1188. end
  1189. else
  1190. handle_propertysym(propsym,propsym^.owner,p1,pd);
  1191. end
  1192. else
  1193. begin
  1194. consume(LECKKLAMMER);
  1195. repeat
  1196. case pd^.deftype of
  1197. pointerdef:
  1198. begin
  1199. p2:=comp_expr(true);
  1200. p1:=gennode(vecn,p1,p2);
  1201. pd:=ppointerdef(pd)^.definition;
  1202. end;
  1203. stringdef : begin
  1204. p2:=comp_expr(true);
  1205. p1:=gennode(vecn,p1,p2);
  1206. pd:=cchardef
  1207. end;
  1208. arraydef : begin
  1209. p2:=comp_expr(true);
  1210. { support SEG:OFS for go32v2 Mem[] }
  1211. if (target_info.target=target_i386_go32v2) and
  1212. (p1^.treetype=loadn) and
  1213. assigned(p1^.symtableentry) and
  1214. assigned(p1^.symtableentry^.owner^.name) and
  1215. (p1^.symtableentry^.owner^.name^='SYSTEM') and
  1216. ((p1^.symtableentry^.name='MEM') or
  1217. (p1^.symtableentry^.name='MEMW') or
  1218. (p1^.symtableentry^.name='MEML')) then
  1219. begin
  1220. if (token=COLON) then
  1221. begin
  1222. consume(COLON);
  1223. p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
  1224. p2:=comp_expr(true);
  1225. p2:=gennode(addn,p2,p3);
  1226. p1:=gennode(vecn,p1,p2);
  1227. p1^.memseg:=true;
  1228. p1^.memindex:=true;
  1229. end
  1230. else
  1231. begin
  1232. p1:=gennode(vecn,p1,p2);
  1233. p1^.memindex:=true;
  1234. end;
  1235. end
  1236. else
  1237. p1:=gennode(vecn,p1,p2);
  1238. pd:=parraydef(pd)^.definition;
  1239. end;
  1240. else
  1241. begin
  1242. Message(cg_e_invalid_qualifier);
  1243. disposetree(p1);
  1244. p1:=genzeronode(errorn);
  1245. again:=false;
  1246. end;
  1247. end;
  1248. if token=COMMA then
  1249. consume(COMMA)
  1250. else
  1251. break;
  1252. until false;
  1253. consume(RECKKLAMMER);
  1254. end;
  1255. end;
  1256. POINT : begin
  1257. consume(POINT);
  1258. if (pd^.deftype=pointerdef) and
  1259. (m_autoderef in aktmodeswitches) then
  1260. begin
  1261. p1:=gensinglenode(derefn,p1);
  1262. pd:=ppointerdef(pd)^.definition;
  1263. end;
  1264. case pd^.deftype of
  1265. recorddef:
  1266. begin
  1267. sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
  1268. if sym=nil then
  1269. begin
  1270. Message1(sym_e_illegal_field,pattern);
  1271. disposetree(p1);
  1272. p1:=genzeronode(errorn);
  1273. end
  1274. else
  1275. begin
  1276. p1:=gensubscriptnode(sym,p1);
  1277. pd:=sym^.definition;
  1278. end;
  1279. consume(ID);
  1280. end;
  1281. classrefdef:
  1282. begin
  1283. classh:=pobjectdef(pclassrefdef(pd)^.definition);
  1284. sym:=nil;
  1285. while assigned(classh) do
  1286. begin
  1287. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1288. srsymtable:=classh^.publicsyms;
  1289. if assigned(sym) then
  1290. break;
  1291. classh:=classh^.childof;
  1292. end;
  1293. consume(ID);
  1294. do_member_read(getaddr,sym,p1,pd,again);
  1295. end;
  1296. objectdef:
  1297. begin
  1298. classh:=pobjectdef(pd);
  1299. sym:=nil;
  1300. store_static:=allow_only_static;
  1301. allow_only_static:=false;
  1302. while assigned(classh) do
  1303. begin
  1304. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1305. srsymtable:=classh^.publicsyms;
  1306. if assigned(sym) then
  1307. break;
  1308. classh:=classh^.childof;
  1309. end;
  1310. allow_only_static:=store_static;
  1311. consume(ID);
  1312. do_member_read(getaddr,sym,p1,pd,again);
  1313. end;
  1314. pointerdef:
  1315. begin
  1316. Message(cg_e_invalid_qualifier);
  1317. if ppointerdef(pd)^.definition^.deftype in [recorddef,objectdef,classrefdef] then
  1318. Message(parser_h_maybe_deref_caret_missing);
  1319. end;
  1320. else
  1321. begin
  1322. Message(cg_e_invalid_qualifier);
  1323. disposetree(p1);
  1324. p1:=genzeronode(errorn);
  1325. end;
  1326. end;
  1327. end;
  1328. else
  1329. begin
  1330. { is this a procedure variable ? }
  1331. if assigned(pd) then
  1332. begin
  1333. if (pd^.deftype=procvardef) then
  1334. begin
  1335. if getprocvar and is_equal(pd,getprocvardef) then
  1336. again:=false
  1337. else
  1338. if (token=LKLAMMER) or
  1339. ((pprocvardef(pd)^.para1=nil) and
  1340. (not((token in [ASSIGNMENT,UNEQUAL,EQUAL]))) and
  1341. (not afterassignment) and
  1342. (not in_args)) then
  1343. begin
  1344. { do this in a strange way }
  1345. { it's not a clean solution }
  1346. p2:=p1;
  1347. p1:=gencallnode(nil,nil);
  1348. p1^.right:=p2;
  1349. p1^.unit_specific:=unit_specific;
  1350. p1^.symtableprocentry:=pprocsym(sym);
  1351. if token=LKLAMMER then
  1352. begin
  1353. consume(LKLAMMER);
  1354. p1^.left:=parse_paras(false,false);
  1355. consume(RKLAMMER);
  1356. end;
  1357. pd:=pprocvardef(pd)^.retdef;
  1358. { proc():= is never possible }
  1359. if token=ASSIGNMENT then
  1360. begin
  1361. Message(cg_e_illegal_expression);
  1362. p1:=genzeronode(errorn);
  1363. again:=false;
  1364. end;
  1365. p1^.resulttype:=pd;
  1366. end
  1367. else
  1368. again:=false;
  1369. p1^.resulttype:=pd;
  1370. end
  1371. else
  1372. again:=false;
  1373. end
  1374. else
  1375. again:=false;
  1376. end;
  1377. end;
  1378. check_tokenpos;
  1379. end; { while again }
  1380. end;
  1381. {---------------------------------------------
  1382. Factor (Main)
  1383. ---------------------------------------------}
  1384. begin
  1385. oldp1:=nil;
  1386. p1:=nil;
  1387. filepos:=tokenpos;
  1388. if token=ID then
  1389. begin
  1390. factor_read_id;
  1391. { handle post fix operators }
  1392. postfixoperators;
  1393. end
  1394. else
  1395. case token of
  1396. _NEW : begin
  1397. consume(_NEW);
  1398. consume(LKLAMMER);
  1399. {allow_type:=true;}
  1400. p1:=factor(false);
  1401. {allow_type:=false;}
  1402. if p1^.treetype<>typen then
  1403. begin
  1404. Message(type_e_type_id_expected);
  1405. disposetree(p1);
  1406. pd:=generrordef;
  1407. end
  1408. else
  1409. pd:=p1^.typenodetype;
  1410. pd2:=pd;
  1411. if (pd^.deftype<>pointerdef) then
  1412. Message(type_e_pointer_type_expected)
  1413. else if {(ppointerdef(pd)^.definition^.deftype<>objectdef)}
  1414. token=RKLAMMER then
  1415. begin
  1416. if (ppointerdef(pd)^.definition^.deftype=objectdef) and
  1417. ((pobjectdef(ppointerdef(pd)^.definition)^.options and oo_hasvmt) <> 0) then
  1418. Message(parser_w_use_extended_syntax_for_objects);
  1419. p1:=gensinglenode(newn,nil);
  1420. p1^.resulttype:=pd2;
  1421. consume(RKLAMMER);
  1422. (*Message(parser_e_pointer_to_class_expected);
  1423. { if an error occurs, read til the end of
  1424. the new statement }
  1425. p1:=genzeronode(errorn);
  1426. l:=1;
  1427. while true do
  1428. begin
  1429. case token of
  1430. LKLAMMER : inc(l);
  1431. RKLAMMER : dec(l);
  1432. end;
  1433. consume(token);
  1434. if l=0 then
  1435. break;
  1436. end;*)
  1437. end
  1438. else
  1439. begin
  1440. disposetree(p1);
  1441. p1:=genzeronode(hnewn);
  1442. p1^.resulttype:=ppointerdef(pd)^.definition;
  1443. consume(COMMA);
  1444. afterassignment:=false;
  1445. { determines the current object defintion }
  1446. classh:=pobjectdef(ppointerdef(pd)^.definition);
  1447. { check for an abstract class }
  1448. if (classh^.options and oo_is_abstract)<>0 then
  1449. Message(sym_e_no_instance_of_abstract_object);
  1450. { search the constructor also in the symbol tables of
  1451. the parents }
  1452. { no constructor found }
  1453. sym:=nil;
  1454. while assigned(classh) do
  1455. begin
  1456. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1457. srsymtable:=classh^.publicsyms;
  1458. if assigned(sym) then
  1459. break;
  1460. classh:=classh^.childof;
  1461. end;
  1462. consume(ID);
  1463. do_member_read(false,sym,p1,pd,again);
  1464. if (p1^.treetype<>calln) or
  1465. (assigned(p1^.procdefinition) and
  1466. ((p1^.procdefinition^.options and poconstructor)=0)) then
  1467. Message(parser_e_expr_have_to_be_constructor_call);
  1468. p1:=gensinglenode(newn,p1);
  1469. { set the resulttype }
  1470. p1^.resulttype:=pd2;
  1471. consume(RKLAMMER);
  1472. end;
  1473. end;
  1474. _SELF : begin
  1475. again:=true;
  1476. consume(_SELF);
  1477. if not assigned(procinfo._class) then
  1478. begin
  1479. p1:=genzeronode(errorn);
  1480. pd:=generrordef;
  1481. again:=false;
  1482. Message(parser_e_self_not_in_method);
  1483. end
  1484. else
  1485. begin
  1486. if (aktprocsym^.definition^.options and poclassmethod)<>0 then
  1487. begin
  1488. { self in class methods is a class reference type }
  1489. pd:=new(pclassrefdef,init(procinfo._class));
  1490. p1:=genselfnode(pd);
  1491. p1^.resulttype:=pd;
  1492. end
  1493. else
  1494. begin
  1495. p1:=genselfnode(procinfo._class);
  1496. p1^.resulttype:=procinfo._class;
  1497. end;
  1498. pd:=p1^.resulttype;
  1499. postfixoperators;
  1500. end;
  1501. end;
  1502. _INHERITED : begin
  1503. again:=true;
  1504. consume(_INHERITED);
  1505. if assigned(procinfo._class) then
  1506. begin
  1507. classh:=procinfo._class^.childof;
  1508. while assigned(classh) do
  1509. begin
  1510. srsymtable:=pobjectdef(classh)^.publicsyms;
  1511. sym:=pvarsym(srsymtable^.search(pattern));
  1512. if assigned(sym) then
  1513. begin
  1514. p1:=genzeronode(typen);
  1515. p1^.resulttype:=classh;
  1516. pd:=p1^.resulttype;
  1517. consume(ID);
  1518. do_member_read(false,sym,p1,pd,again);
  1519. break;
  1520. end;
  1521. classh:=classh^.childof;
  1522. end;
  1523. if classh=nil then
  1524. begin
  1525. Message1(sym_e_id_no_member,pattern);
  1526. again:=false;
  1527. pd:=generrordef;
  1528. p1:=genzeronode(errorn);
  1529. end;
  1530. end
  1531. else
  1532. begin
  1533. Message(parser_e_generic_methods_only_in_methods);
  1534. again:=false;
  1535. pd:=generrordef;
  1536. p1:=genzeronode(errorn);
  1537. end;
  1538. postfixoperators;
  1539. end;
  1540. INTCONST : begin
  1541. valint(pattern,l,code);
  1542. if code<>0 then
  1543. begin
  1544. val(pattern,d,code);
  1545. if code<>0 then
  1546. begin
  1547. Message(cg_e_invalid_integer);
  1548. consume(INTCONST);
  1549. l:=1;
  1550. p1:=genordinalconstnode(l,s32bitdef);
  1551. end
  1552. else
  1553. begin
  1554. consume(INTCONST);
  1555. p1:=genrealconstnode(d,bestrealdef^);
  1556. end;
  1557. end
  1558. else
  1559. begin
  1560. consume(INTCONST);
  1561. p1:=genordinalconstnode(l,s32bitdef);
  1562. end;
  1563. end;
  1564. REALNUMBER : begin
  1565. val(pattern,d,code);
  1566. if code<>0 then
  1567. begin
  1568. Message(parser_e_error_in_real);
  1569. d:=1.0;
  1570. end;
  1571. consume(REALNUMBER);
  1572. p1:=genrealconstnode(d,bestrealdef^);
  1573. end;
  1574. _STRING : begin
  1575. pd:=stringtype;
  1576. { STRING can be also a type cast }
  1577. if token=LKLAMMER then
  1578. begin
  1579. consume(LKLAMMER);
  1580. p1:=comp_expr(true);
  1581. consume(RKLAMMER);
  1582. p1:=gentypeconvnode(p1,pd);
  1583. p1^.explizit:=true;
  1584. { handle postfix operators here e.g. string(a)[10] }
  1585. again:=true;
  1586. postfixoperators;
  1587. end
  1588. else
  1589. p1:=gentypenode(pd);
  1590. end;
  1591. _FILE : begin
  1592. pd:=cfiledef;
  1593. consume(_FILE);
  1594. { FILE can be also a type cast }
  1595. if token=LKLAMMER then
  1596. begin
  1597. consume(LKLAMMER);
  1598. p1:=comp_expr(true);
  1599. consume(RKLAMMER);
  1600. p1:=gentypeconvnode(p1,pd);
  1601. p1^.explizit:=true;
  1602. { handle postfix operators here e.g. string(a)[10] }
  1603. again:=true;
  1604. postfixoperators;
  1605. end
  1606. else
  1607. p1:=gentypenode(pd);
  1608. end;
  1609. CSTRING : begin
  1610. p1:=genstringconstnode(pattern);
  1611. consume(CSTRING);
  1612. end;
  1613. CCHAR : begin
  1614. p1:=genordinalconstnode(ord(pattern[1]),cchardef);
  1615. consume(CCHAR);
  1616. end;
  1617. KLAMMERAFFE : begin
  1618. consume(KLAMMERAFFE);
  1619. p1:=factor(true);
  1620. p1:=gensinglenode(addrn,p1);
  1621. end;
  1622. LKLAMMER : begin
  1623. consume(LKLAMMER);
  1624. p1:=comp_expr(true);
  1625. consume(RKLAMMER);
  1626. { it's not a good solution }
  1627. { but (a+b)^ makes some problems }
  1628. if token in [CARET,POINT,LECKKLAMMER] then
  1629. begin
  1630. { we need the resulttype }
  1631. { of the expression in pd }
  1632. do_firstpass(p1);
  1633. pd:=p1^.resulttype;
  1634. again:=true;
  1635. postfixoperators;
  1636. end;
  1637. end;
  1638. LECKKLAMMER : begin
  1639. consume(LECKKLAMMER);
  1640. p1:=factor_read_set;
  1641. consume(RECKKLAMMER);
  1642. end;
  1643. PLUS : begin
  1644. consume(PLUS);
  1645. p1:=factor(false);
  1646. end;
  1647. MINUS : begin
  1648. consume(MINUS);
  1649. p1:=factor(false);
  1650. p1:=gensinglenode(umminusn,p1);
  1651. end;
  1652. _NOT : begin
  1653. consume(_NOT);
  1654. p1:=factor(false);
  1655. p1:=gensinglenode(notn,p1);
  1656. end;
  1657. _TRUE : begin
  1658. consume(_TRUE);
  1659. p1:=genordinalconstnode(1,booldef);
  1660. end;
  1661. _FALSE : begin
  1662. consume(_FALSE);
  1663. p1:=genordinalconstnode(0,booldef);
  1664. end;
  1665. _NIL : begin
  1666. consume(_NIL);
  1667. p1:=genzeronode(niln);
  1668. end;
  1669. else
  1670. begin
  1671. p1:=genzeronode(errorn);
  1672. consume(token);
  1673. Message(cg_e_illegal_expression);
  1674. end;
  1675. end;
  1676. { generate error node if no node is created }
  1677. if not assigned(p1) then
  1678. p1:=genzeronode(errorn);
  1679. factor:=p1;
  1680. check_tokenpos;
  1681. end;
  1682. {****************************************************************************
  1683. Sub_Expr
  1684. ****************************************************************************}
  1685. type
  1686. Toperator_precedence=(opcompare,opaddition,opmultiply);
  1687. Ttok2nodeRec=record
  1688. tok : ttoken;
  1689. nod : ttreetyp;
  1690. end;
  1691. const
  1692. tok2nodes=23;
  1693. tok2node:array[1..tok2nodes] of ttok2noderec=(
  1694. (tok:PLUS ;nod:addn),
  1695. (tok:MINUS ;nod:subn),
  1696. (tok:STAR ;nod:muln),
  1697. (tok:SLASH ;nod:slashn),
  1698. (tok:EQUAL ;nod:equaln),
  1699. (tok:GT ;nod:gtn),
  1700. (tok:LT ;nod:ltn),
  1701. (tok:GTE ;nod:gten),
  1702. (tok:LTE ;nod:lten),
  1703. (tok:SYMDIF ;nod:symdifn),
  1704. (tok:STARSTAR;nod:starstarn),
  1705. (tok:CARET ;nod:caretn),
  1706. (tok:UNEQUAL ;nod:unequaln),
  1707. (tok:_AS ;nod:asn),
  1708. (tok:_IN ;nod:inn),
  1709. (tok:_IS ;nod:isn),
  1710. (tok:_OR ;nod:orn),
  1711. (tok:_AND ;nod:andn),
  1712. (tok:_DIV ;nod:divn),
  1713. (tok:_MOD ;nod:modn),
  1714. (tok:_SHL ;nod:shln),
  1715. (tok:_SHR ;nod:shrn),
  1716. (tok:_XOR ;nod:xorn)
  1717. );
  1718. operator_levels:array[Toperator_precedence] of set of Ttoken=
  1719. ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
  1720. [PLUS,MINUS,_OR,_XOR],
  1721. [CARET,SYMDIF,STARSTAR,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
  1722. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;
  1723. {Reads a subexpression while the operators are of the current precedence
  1724. level, or any higher level. Replaces the old term, simpl_expr and
  1725. simpl2_expr.}
  1726. var
  1727. low,high,mid : longint;
  1728. p1,p2 : Ptree;
  1729. oldt : Ttoken;
  1730. filepos : tfileposinfo;
  1731. begin
  1732. if pred_level=opmultiply then
  1733. p1:=factor(false)
  1734. else
  1735. p1:=sub_expr(succ(pred_level),true);
  1736. repeat
  1737. if (token in operator_levels[pred_level]) and
  1738. ((token<>EQUAL) or accept_equal) then
  1739. begin
  1740. oldt:=token;
  1741. filepos:=tokenpos;
  1742. consume(token);
  1743. if pred_level=opmultiply then
  1744. p2:=factor(false)
  1745. else
  1746. p2:=sub_expr(succ(pred_level),true);
  1747. low:=1;
  1748. high:=tok2nodes;
  1749. while (low<high) do
  1750. begin
  1751. mid:=(low+high+1) shr 1;
  1752. if oldt<tok2node[mid].tok then
  1753. high:=mid-1
  1754. else
  1755. low:=mid;
  1756. end;
  1757. if tok2node[high].tok=oldt then
  1758. p1:=gennode(tok2node[high].nod,p1,p2)
  1759. else
  1760. p1:=gennode(nothingn,p1,p2);
  1761. set_tree_filepos(p1,filepos);
  1762. end
  1763. else
  1764. break;
  1765. until false;
  1766. sub_expr:=p1;
  1767. end;
  1768. procedure check_tp_procvar(var p : ptree);
  1769. var
  1770. p1 : ptree;
  1771. begin
  1772. if (m_tp_procvar in aktmodeswitches) and
  1773. (not afterassignment) and
  1774. (not in_args) and (p^.treetype=loadn) then
  1775. begin
  1776. { support if procvar then for tp7 and many other expression like this }
  1777. firstpass(p);
  1778. if p^.resulttype^.deftype=procvardef then
  1779. begin
  1780. p1:=gencallnode(nil,nil);
  1781. p1^.right:=p;
  1782. p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
  1783. firstpass(p1);
  1784. p:=p1;
  1785. end;
  1786. end;
  1787. end;
  1788. function comp_expr(accept_equal : boolean):Ptree;
  1789. var
  1790. oldafterassignment : boolean;
  1791. p1 : ptree;
  1792. begin
  1793. oldafterassignment:=afterassignment;
  1794. afterassignment:=true;
  1795. p1:=sub_expr(opcompare,accept_equal);
  1796. afterassignment:=oldafterassignment;
  1797. if (m_tp_procvar in aktmodeswitches) then
  1798. check_tp_procvar(p1);
  1799. comp_expr:=p1;
  1800. end;
  1801. function expr : ptree;
  1802. var
  1803. p1,p2 : ptree;
  1804. oldafterassignment : boolean;
  1805. oldp1 : ptree;
  1806. filepos : tfileposinfo;
  1807. begin
  1808. oldafterassignment:=afterassignment;
  1809. p1:=sub_expr(opcompare,true);
  1810. filepos:=tokenpos;
  1811. if (m_tp_procvar in aktmodeswitches) and
  1812. (token<>ASSIGNMENT) then
  1813. check_tp_procvar(p1);
  1814. if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  1815. afterassignment:=true;
  1816. oldp1:=p1;
  1817. case token of
  1818. POINTPOINT : begin
  1819. consume(POINTPOINT);
  1820. p2:=sub_expr(opcompare,true);
  1821. p1:=gennode(rangen,p1,p2);
  1822. end;
  1823. ASSIGNMENT : begin
  1824. consume(ASSIGNMENT);
  1825. { avoid a firstpass of a procedure if
  1826. it must be assigned to a procvar }
  1827. { should be recursive for a:=b:=c !!! }
  1828. if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
  1829. begin
  1830. getprocvar:=true;
  1831. getprocvardef:=pprocvardef(p1^.resulttype);
  1832. end;
  1833. p2:=sub_expr(opcompare,true);
  1834. if getprocvar and (p2^.treetype=calln) then
  1835. handle_procvar(getprocvardef,p2);
  1836. { also allow p:= proc(t); !! (PM) }
  1837. if getprocvar and (p2^.treetype=typeconvn) and
  1838. (p2^.left^.treetype=calln) then
  1839. handle_procvar(getprocvardef,p2^.left);
  1840. getprocvar:=false;
  1841. p1:=gennode(assignn,p1,p2);
  1842. end;
  1843. { this is the code for C like assignements }
  1844. { from an improvement of Peter Schaefer }
  1845. _PLUSASN : begin
  1846. consume(_PLUSASN );
  1847. p2:=sub_expr(opcompare,true);
  1848. p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
  1849. { was first
  1850. p1:=gennode(assignn,p1,gennode(addn,p1,p2));
  1851. but disposetree assumes that we have a real
  1852. *** tree *** }
  1853. end;
  1854. _MINUSASN : begin
  1855. consume(_MINUSASN );
  1856. p2:=sub_expr(opcompare,true);
  1857. p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
  1858. end;
  1859. _STARASN : begin
  1860. consume(_STARASN );
  1861. p2:=sub_expr(opcompare,true);
  1862. p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
  1863. end;
  1864. _SLASHASN : begin
  1865. consume(_SLASHASN );
  1866. p2:=sub_expr(opcompare,true);
  1867. p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
  1868. end;
  1869. end;
  1870. afterassignment:=oldafterassignment;
  1871. if p1<>oldp1 then
  1872. set_tree_filepos(p1,filepos);
  1873. expr:=p1;
  1874. end;
  1875. function get_intconst:longint;
  1876. {Reads an expression, tries to evalute it and check if it is an integer
  1877. constant. Then the constant is returned.}
  1878. var
  1879. p:Ptree;
  1880. begin
  1881. p:=comp_expr(true);
  1882. do_firstpass(p);
  1883. if not codegenerror then
  1884. begin
  1885. if (p^.treetype<>ordconstn) and
  1886. (p^.resulttype^.deftype=orddef) and
  1887. not(Porddef(p^.resulttype)^.typ in [uvoid,uchar,bool8bit,bool16bit,bool32bit]) then
  1888. Message(cg_e_illegal_expression)
  1889. else
  1890. get_intconst:=p^.value;
  1891. end;
  1892. disposetree(p);
  1893. end;
  1894. function get_stringconst:string;
  1895. {Reads an expression, tries to evaluate it and checks if it is a string
  1896. constant. Then the constant is returned.}
  1897. var
  1898. p:Ptree;
  1899. begin
  1900. get_stringconst:='';
  1901. p:=comp_expr(true);
  1902. do_firstpass(p);
  1903. if p^.treetype<>stringconstn then
  1904. begin
  1905. if (p^.treetype=ordconstn) and is_char(p^.resulttype) then
  1906. get_stringconst:=char(p^.value)
  1907. else
  1908. Message(cg_e_illegal_expression);
  1909. end
  1910. else
  1911. get_stringconst:=strpas(p^.value_str);
  1912. disposetree(p);
  1913. end;
  1914. end.
  1915. {
  1916. $Log$
  1917. Revision 1.113 1999-06-13 22:41:05 peter
  1918. * merged from fixes
  1919. Revision 1.112.2.1 1999/06/13 22:38:09 peter
  1920. * tp_procvar check for loading of procvars when getaddr=false
  1921. Revision 1.112 1999/06/02 22:44:11 pierre
  1922. * previous wrong log corrected
  1923. Revision 1.111 1999/06/02 22:25:43 pierre
  1924. * changed $ifdef FPC @ into $ifndef TP
  1925. * changes for correct procvar handling under tp mode
  1926. Revision 1.110 1999/06/01 19:27:55 peter
  1927. * better checks for procvar and methodpointer
  1928. Revision 1.109 1999/05/27 19:44:46 peter
  1929. * removed oldasm
  1930. * plabel -> pasmlabel
  1931. * -a switches to source writing automaticly
  1932. * assembler readers OOPed
  1933. * asmsymbol automaticly external
  1934. * jumptables and other label fixes for asm readers
  1935. Revision 1.108 1999/05/18 14:15:54 peter
  1936. * containsself fixes
  1937. * checktypes()
  1938. Revision 1.107 1999/05/18 09:52:18 peter
  1939. * procedure of object and addrn fixes
  1940. Revision 1.106 1999/05/16 17:06:31 peter
  1941. * remove firstcallparan which looks obsolete
  1942. Revision 1.105 1999/05/12 22:36:09 florian
  1943. * override isn't allowed in objects!
  1944. Revision 1.104 1999/05/07 10:35:23 florian
  1945. * first fix for a problem with method pointer properties, still doesn't work
  1946. with WITH
  1947. Revision 1.103 1999/05/06 21:40:16 peter
  1948. * fixed crash
  1949. Revision 1.101 1999/05/06 09:05:21 peter
  1950. * generic write_float and str_float
  1951. * fixed constant float conversions
  1952. Revision 1.100 1999/05/04 21:44:57 florian
  1953. * changes to compile it with Delphi 4.0
  1954. Revision 1.99 1999/05/01 13:24:31 peter
  1955. * merged nasm compiler
  1956. * old asm moved to oldasm/
  1957. Revision 1.98 1999/04/26 18:29:56 peter
  1958. * farpointerdef moved into pointerdef.is_far
  1959. Revision 1.97 1999/04/19 09:27:48 peter
  1960. * removed my property fix
  1961. Revision 1.96 1999/04/19 09:13:47 peter
  1962. * class property without write support
  1963. Revision 1.95 1999/04/19 06:10:08 florian
  1964. * property problem fixed: a propertysym is only a write
  1965. access if it is followed by a assignment token
  1966. Revision 1.94 1999/04/17 13:12:17 peter
  1967. * addr() internal
  1968. Revision 1.93 1999/04/15 09:00:08 peter
  1969. * fixed property write
  1970. Revision 1.92 1999/04/08 20:59:43 florian
  1971. * fixed problem with default properties which are a class
  1972. * case bug (from the mailing list with -O2) fixed, the
  1973. distance of the case labels can be greater than the positive
  1974. range of a longint => it is now a dword for fpc
  1975. Revision 1.91 1999/04/06 11:21:56 peter
  1976. * more use of ttoken
  1977. Revision 1.90 1999/03/31 13:55:12 peter
  1978. * assembler inlining working for ag386bin
  1979. Revision 1.89 1999/03/26 00:05:36 peter
  1980. * released valintern
  1981. + deffile is now removed when compiling is finished
  1982. * ^( compiles now correct
  1983. + static directive
  1984. * shrd fixed
  1985. Revision 1.88 1999/03/24 23:17:15 peter
  1986. * fixed bugs 212,222,225,227,229,231,233
  1987. Revision 1.87 1999/03/16 17:52:52 jonas
  1988. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  1989. * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  1990. * in cgai386: also small fixes to emitrangecheck
  1991. Revision 1.86 1999/03/04 13:55:44 pierre
  1992. * some m68k fixes (still not compilable !)
  1993. * new(tobj) does not give warning if tobj has no VMT !
  1994. Revision 1.85 1999/02/22 15:09:39 florian
  1995. * behaviaor of PROTECTED and PRIVATE fixed, works now like TP/Delphi
  1996. Revision 1.84 1999/02/22 02:15:26 peter
  1997. * updates for ag386bin
  1998. Revision 1.83 1999/02/11 09:46:25 pierre
  1999. * fix for normal method calls inside static methods :
  2000. WARNING there were both parser and codegen errors !!
  2001. added static_call boolean to calln tree
  2002. Revision 1.82 1999/01/28 14:06:47 florian
  2003. * small fix for method pointers
  2004. * found the annoying strpas bug, mainly nested call to type cast which
  2005. use ansistrings crash
  2006. Revision 1.81 1999/01/27 00:13:55 florian
  2007. * "procedure of object"-stuff fixed
  2008. Revision 1.80 1999/01/21 16:41:01 pierre
  2009. * fix for constructor inside with statements
  2010. Revision 1.79 1998/12/30 22:15:48 peter
  2011. + farpointer type
  2012. * absolutesym now also stores if its far
  2013. Revision 1.78 1998/12/11 00:03:32 peter
  2014. + globtype,tokens,version unit splitted from globals
  2015. Revision 1.77 1998/12/04 10:18:09 florian
  2016. * some stuff for procedures of object added
  2017. * bug with overridden virtual constructors fixed (reported by Italo Gomes)
  2018. Revision 1.76 1998/11/27 14:50:40 peter
  2019. + open strings, $P switch support
  2020. Revision 1.75 1998/11/25 19:12:51 pierre
  2021. * var:=new(pointer_type) support added
  2022. Revision 1.74 1998/11/13 10:18:11 peter
  2023. + nil constants
  2024. Revision 1.73 1998/11/05 12:02:52 peter
  2025. * released useansistring
  2026. * removed -Sv, its now available in fpc modes
  2027. Revision 1.72 1998/11/04 10:11:41 peter
  2028. * ansistring fixes
  2029. Revision 1.71 1998/10/22 23:57:29 peter
  2030. * fixed filedef for typenodetype
  2031. Revision 1.70 1998/10/21 15:12:54 pierre
  2032. * bug fix for IOCHECK inside a procedure with iocheck modifier
  2033. * removed the GPF for unexistant overloading
  2034. (firstcall was called with procedinition=nil !)
  2035. * changed typen to what Florian proposed
  2036. gentypenode(p : pdef) sets the typenodetype field
  2037. and resulttype is only set if inside bt_type block !
  2038. Revision 1.69 1998/10/20 15:10:19 pierre
  2039. * type ptree only allowed inside expression
  2040. if following sizeof typeof low high or as first arg of new !!
  2041. Revision 1.68 1998/10/20 11:15:44 pierre
  2042. * calling of private method allowed inside child object method
  2043. Revision 1.67 1998/10/19 08:54:57 pierre
  2044. * wrong stabs info corrected once again !!
  2045. + variable vmt offset with vmt field only if required
  2046. implemented now !!!
  2047. Revision 1.66 1998/10/15 15:13:28 pierre
  2048. + added oo_hasconstructor and oo_hasdestructor
  2049. for objects options
  2050. Revision 1.65 1998/10/13 13:10:24 peter
  2051. * new style for m68k/i386 infos and enums
  2052. Revision 1.64 1998/10/12 12:20:55 pierre
  2053. + added tai_const_symbol_offset
  2054. for r : pointer = @var.field;
  2055. * better message for different arg names on implementation
  2056. of function
  2057. Revision 1.63 1998/10/12 10:28:30 florian
  2058. + auto dereferencing of pointers to structured types in delphi mode
  2059. Revision 1.62 1998/10/12 10:05:41 peter
  2060. * fixed mem leak with arrayconstrutor
  2061. Revision 1.61 1998/10/05 13:57:15 peter
  2062. * crash preventions
  2063. Revision 1.60 1998/10/05 12:32:46 peter
  2064. + assert() support
  2065. Revision 1.59 1998/10/01 14:56:24 peter
  2066. * crash preventions
  2067. Revision 1.58 1998/09/30 07:40:35 florian
  2068. * better error recovering
  2069. Revision 1.57 1998/09/28 16:18:16 florian
  2070. * two fixes to get ansi strings work
  2071. Revision 1.56 1998/09/26 17:45:36 peter
  2072. + idtoken and only one token table
  2073. Revision 1.55 1998/09/24 23:49:10 peter
  2074. + aktmodeswitches
  2075. Revision 1.54 1998/09/23 15:46:39 florian
  2076. * problem with with and classes fixed
  2077. Revision 1.53 1998/09/23 09:58:54 peter
  2078. * first working array of const things
  2079. Revision 1.52 1998/09/20 09:38:45 florian
  2080. * hasharray for defs fixed
  2081. * ansistring code generation corrected (init/final, assignement)
  2082. Revision 1.51 1998/09/18 16:03:43 florian
  2083. * some changes to compile with Delphi
  2084. Revision 1.50 1998/09/17 13:41:18 pierre
  2085. sizeof(TPOINT) problem
  2086. Revision 1.49.2.1 1998/09/17 08:42:31 pierre
  2087. TPOINT sizeof fix
  2088. Revision 1.49 1998/09/09 11:50:53 pierre
  2089. * forward def are not put in record or objects
  2090. + added check for forwards also in record and objects
  2091. * dummy parasymtable for unit initialization removed from
  2092. symtable stack
  2093. Revision 1.48 1998/09/07 22:25:53 peter
  2094. * fixed str(boolean,string) which was allowed
  2095. * fixed write(' ':<int expression>) only constants where allowed :(
  2096. Revision 1.47 1998/09/07 18:46:10 peter
  2097. * update smartlinking, uses getdatalabel
  2098. * renamed ptree.value vars to value_str,value_real,value_set
  2099. Revision 1.46 1998/09/04 08:42:03 peter
  2100. * updated some error messages
  2101. Revision 1.45 1998/09/01 17:39:49 peter
  2102. + internal constant functions
  2103. Revision 1.44 1998/08/28 10:54:24 peter
  2104. * fixed smallset generation from elements, it has never worked before!
  2105. Revision 1.43 1998/08/23 16:07:24 florian
  2106. * internalerror with mod/div fixed
  2107. Revision 1.42 1998/08/21 14:08:50 pierre
  2108. + TEST_FUNCRET now default (old code removed)
  2109. works also for m68k (at least compiles)
  2110. Revision 1.41 1998/08/20 21:36:39 peter
  2111. * fixed 'with object do' bug
  2112. Revision 1.40 1998/08/20 09:26:41 pierre
  2113. + funcret setting in underproc testing
  2114. compile with _dTEST_FUNCRET
  2115. Revision 1.39 1998/08/18 16:48:48 pierre
  2116. * bug for -So proc assignment to p^rocvar fixed
  2117. Revision 1.38 1998/08/18 14:17:09 pierre
  2118. * bug about assigning the return value of a function to
  2119. a procvar fixed : warning
  2120. assigning a proc to a procvar need @ in FPC mode !!
  2121. * missing file/line info restored
  2122. Revision 1.37 1998/08/18 09:24:43 pierre
  2123. * small warning position bug fixed
  2124. * support_mmx switches splitting was missing
  2125. * rhide error and warning output corrected
  2126. Revision 1.36 1998/08/15 16:50:29 peter
  2127. * fixed proc()=expr which was not allowed anymore by my previous fix
  2128. Revision 1.35 1998/08/14 18:18:46 peter
  2129. + dynamic set contruction
  2130. * smallsets are now working (always longint size)
  2131. Revision 1.34 1998/08/13 11:00:12 peter
  2132. * fixed procedure<>procedure construct
  2133. Revision 1.33 1998/08/11 15:31:39 peter
  2134. * write extended to ppu file
  2135. * new version 0.99.7
  2136. Revision 1.32 1998/08/11 14:05:32 peter
  2137. * fixed sizeof(array of char)
  2138. Revision 1.31 1998/08/10 14:50:11 peter
  2139. + localswitches, moduleswitches, globalswitches splitting
  2140. Revision 1.30 1998/07/28 21:52:54 florian
  2141. + implementation of raise and try..finally
  2142. + some misc. exception stuff
  2143. Revision 1.29 1998/07/27 21:57:13 florian
  2144. * fix to allow tv like stream registration:
  2145. @tmenu.load doesn't work if load had parameters or if load was only
  2146. declared in an anchestor class of tmenu
  2147. Revision 1.28 1998/07/14 21:46:51 peter
  2148. * updated messages file
  2149. Revision 1.27 1998/06/25 14:04:23 peter
  2150. + internal inc/dec
  2151. Revision 1.26 1998/06/09 16:01:46 pierre
  2152. + added procedure directive parsing for procvars
  2153. (accepted are popstack cdecl and pascal)
  2154. + added C vars with the following syntax
  2155. var C calias 'true_c_name';(can be followed by external)
  2156. reason is that you must add the Cprefix
  2157. which is target dependent
  2158. Revision 1.25 1998/06/05 14:37:33 pierre
  2159. * fixes for inline for operators
  2160. * inline procedure more correctly restricted
  2161. Revision 1.24 1998/06/04 23:51:52 peter
  2162. * m68k compiles
  2163. + .def file creation moved to gendef.pas so it could also be used
  2164. for win32
  2165. Revision 1.23 1998/06/04 09:55:40 pierre
  2166. * demangled name of procsym reworked to become independant of the mangling scheme
  2167. Revision 1.22 1998/06/02 17:03:03 pierre
  2168. * with node corrected for objects
  2169. * small bugs for SUPPORT_MMX fixed
  2170. Revision 1.21 1998/05/27 19:45:05 peter
  2171. * symtable.pas splitted into includefiles
  2172. * symtable adapted for $ifdef NEWPPU
  2173. Revision 1.20 1998/05/26 07:53:59 pierre
  2174. * bug fix for empty sets (nil pd was dereferenced )
  2175. Revision 1.19 1998/05/25 17:11:43 pierre
  2176. * firstpasscount bug fixed
  2177. now all is already set correctly the first time
  2178. under EXTDEBUG try -gp to skip all other firstpasses
  2179. it works !!
  2180. * small bug fixes
  2181. - for smallsets with -dTESTSMALLSET
  2182. - some warnings removed (by correcting code !)
  2183. Revision 1.18 1998/05/23 01:21:20 peter
  2184. + aktasmmode, aktoptprocessor, aktoutputformat
  2185. + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
  2186. + $LIBNAME to set the library name where the unit will be put in
  2187. * splitted cgi386 a bit (codeseg to large for bp7)
  2188. * nasm, tasm works again. nasm moved to ag386nsm.pas
  2189. Revision 1.17 1998/05/22 12:37:03 carl
  2190. * crash bugfix (patched msanually to main branch)
  2191. Revision 1.16 1998/05/21 19:33:32 peter
  2192. + better procedure directive handling and only one table
  2193. Revision 1.15 1998/05/20 09:42:35 pierre
  2194. + UseTokenInfo now default
  2195. * unit in interface uses and implementation uses gives error now
  2196. * only one error for unknown symbol (uses lastsymknown boolean)
  2197. the problem came from the label code !
  2198. + first inlined procedures and function work
  2199. (warning there might be allowed cases were the result is still wrong !!)
  2200. * UseBrower updated gives a global list of all position of all used symbols
  2201. with switch -gb
  2202. Revision 1.14 1998/05/11 13:07:56 peter
  2203. + $ifdef NEWPPU for the new ppuformat
  2204. + $define GDB not longer required
  2205. * removed all warnings and stripped some log comments
  2206. * no findfirst/findnext anymore to remove smartlink *.o files
  2207. Revision 1.13 1998/05/06 08:38:45 pierre
  2208. * better position info with UseTokenInfo
  2209. UseTokenInfo greatly simplified
  2210. + added check for changed tree after first time firstpass
  2211. (if we could remove all the cases were it happen
  2212. we could skip all firstpass if firstpasscount > 1)
  2213. Only with ExtDebug
  2214. Revision 1.12 1998/05/05 12:05:42 florian
  2215. * problems with properties fixed
  2216. * crash fixed: i:=l when i and l are undefined, was a problem with
  2217. implementation of private/protected
  2218. Revision 1.11 1998/05/04 11:22:26 florian
  2219. * problem with DOM solved: it crashes when accessing a property in a method
  2220. Revision 1.10 1998/05/01 16:38:45 florian
  2221. * handling of private and protected fixed
  2222. + change_keywords_to_tp implemented to remove
  2223. keywords which aren't supported by tp
  2224. * break and continue are now symbols of the system unit
  2225. + widestring, longstring and ansistring type released
  2226. Revision 1.9 1998/04/29 10:33:58 pierre
  2227. + added some code for ansistring (not complete nor working yet)
  2228. * corrected operator overloading
  2229. * corrected nasm output
  2230. + started inline procedures
  2231. + added starstarn : use ** for exponentiation (^ gave problems)
  2232. + started UseTokenInfo cond to get accurate positions
  2233. Revision 1.8 1998/04/14 23:27:03 florian
  2234. + exclude/include with constant second parameter added
  2235. Revision 1.7 1998/04/09 23:02:15 florian
  2236. * small problems solved to get remake3 work
  2237. Revision 1.6 1998/04/09 22:16:35 florian
  2238. * problem with previous REGALLOC solved
  2239. * improved property support
  2240. Revision 1.5 1998/04/08 10:26:09 florian
  2241. * correct error handling of virtual constructors
  2242. * problem with new type declaration handling fixed
  2243. Revision 1.4 1998/04/07 22:45:05 florian
  2244. * bug0092, bug0115 and bug0121 fixed
  2245. + packed object/class/array
  2246. Revision 1.3 1998/04/07 13:19:46 pierre
  2247. * bugfixes for reset_gdb_info
  2248. in MEM parsing for go32v2
  2249. better external symbol creation
  2250. support for rhgdb.exe (lowercase file names)
  2251. }