pexpr.pas 95 KB

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