pexpr.pas 91 KB

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