pexpr.pas 95 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. Does parsing of expression for Free Pascal
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pexpr;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. symtype,
  23. node,
  24. cpuinfo;
  25. { reads a whole expression }
  26. function expr : tnode;
  27. { reads an expression without assignements and .. }
  28. function comp_expr(accept_equal : boolean):tnode;
  29. { reads a single factor }
  30. function factor(getaddr : boolean) : tnode;
  31. function string_dec : pdef;
  32. { the ID token has to be consumed before calling this function }
  33. procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : tnode;
  34. var pd : pdef;var again : boolean);
  35. function get_intconst:TConstExprInt;
  36. function get_stringconst:string;
  37. implementation
  38. uses
  39. { common }
  40. cutils,cobjects,
  41. { global }
  42. globtype,globals,tokens,verbose,
  43. systems,widestr,
  44. { symtable }
  45. symconst,symbase,symdef,symsym,symtable,types,
  46. { pass 1 }
  47. pass_1,htypechk,
  48. nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
  49. { parser }
  50. scanner,
  51. pbase,
  52. { codegen }
  53. {$ifdef newcg}
  54. cgbase
  55. {$else}
  56. hcodegen
  57. {$endif}
  58. ;
  59. { sub_expr(opmultiply) is need to get -1 ** 4 to be
  60. read as - (1**4) and not (-1)**4 PM }
  61. type
  62. Toperator_precedence=(opcompare,opaddition,opmultiply,oppower);
  63. const
  64. highest_precedence = oppower;
  65. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):tnode;forward;
  66. const
  67. allow_type : boolean = true;
  68. got_addrn : boolean = false;
  69. auto_inherited : boolean = false;
  70. function string_dec : pdef;
  71. { reads a string type with optional length }
  72. { and returns a pointer to the string }
  73. { definition }
  74. var
  75. p : tnode;
  76. d : pdef;
  77. begin
  78. consume(_STRING);
  79. if token=_LECKKLAMMER then
  80. begin
  81. consume(_LECKKLAMMER);
  82. p:=comp_expr(true);
  83. do_firstpass(p);
  84. if not is_constintnode(p) then
  85. begin
  86. Message(cg_e_illegal_expression);
  87. { error recovery }
  88. consume(_RECKKLAMMER);
  89. d:=cshortstringdef;
  90. end
  91. else
  92. begin
  93. if (tordconstnode(p).value<=0) then
  94. begin
  95. Message(parser_e_invalid_string_size);
  96. tordconstnode(p).value:=255;
  97. end;
  98. consume(_RECKKLAMMER);
  99. if tordconstnode(p).value>255 then
  100. d:=new(pstringdef,longinit(tordconstnode(p).value))
  101. else
  102. if tordconstnode(p).value<>255 then
  103. d:=new(pstringdef,shortinit(tordconstnode(p).value))
  104. else
  105. d:=cshortstringdef;
  106. end;
  107. p.free;
  108. end
  109. else
  110. begin
  111. if cs_ansistrings in aktlocalswitches then
  112. d:=cansistringdef
  113. else
  114. d:=cshortstringdef;
  115. end;
  116. string_dec:=d;
  117. end;
  118. function parse_paras(__colon,in_prop_paras : boolean) : tnode;
  119. var
  120. p1,p2 : tnode;
  121. end_of_paras : ttoken;
  122. begin
  123. if in_prop_paras then
  124. end_of_paras:=_RECKKLAMMER
  125. else
  126. end_of_paras:=_RKLAMMER;
  127. if token=end_of_paras then
  128. begin
  129. parse_paras:=nil;
  130. exit;
  131. end;
  132. p2:=nil;
  133. inc(parsing_para_level);
  134. while true do
  135. begin
  136. p1:=comp_expr(true);
  137. p2:=gencallparanode(p1,p2);
  138. { it's for the str(l:5,s); }
  139. if __colon and (token=_COLON) then
  140. begin
  141. consume(_COLON);
  142. p1:=comp_expr(true);
  143. p2:=gencallparanode(p1,p2);
  144. include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
  145. if token=_COLON then
  146. begin
  147. consume(_COLON);
  148. p1:=comp_expr(true);
  149. p2:=gencallparanode(p1,p2);
  150. include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
  151. end
  152. end;
  153. if token=_COMMA then
  154. consume(_COMMA)
  155. else
  156. break;
  157. end;
  158. dec(parsing_para_level);
  159. parse_paras:=p2;
  160. end;
  161. procedure check_tp_procvar(var p : tnode);
  162. var
  163. p1 : tnode;
  164. begin
  165. if (m_tp_procvar in aktmodeswitches) and
  166. (not got_addrn) and
  167. (not in_args) and
  168. (p.nodetype=loadn) then
  169. begin
  170. { support if procvar then for tp7 and many other expression like this }
  171. do_firstpass(p);
  172. set_varstate(p,false);
  173. { reset varstateset to maybe set used state later web bug769 PM }
  174. unset_varstate(p);
  175. if not(getprocvar) and (p.resulttype^.deftype=procvardef) then
  176. begin
  177. p1:=gencallnode(nil,nil);
  178. tcallnode(p1).right:=p;
  179. p1.resulttype:=pprocvardef(p.resulttype)^.rettype.def;
  180. firstpass(p1);
  181. p:=p1;
  182. end;
  183. end;
  184. end;
  185. function statement_syssym(l : longint;var pd : pdef) : tnode;
  186. var
  187. p1,p2,paras : tnode;
  188. prev_in_args : boolean;
  189. begin
  190. prev_in_args:=in_args;
  191. case l of
  192. in_ord_x :
  193. begin
  194. consume(_LKLAMMER);
  195. in_args:=true;
  196. p1:=comp_expr(true);
  197. consume(_RKLAMMER);
  198. do_firstpass(p1);
  199. p1:=geninlinenode(in_ord_x,false,p1);
  200. do_firstpass(p1);
  201. statement_syssym := p1;
  202. pd:=p1.resulttype;
  203. end;
  204. in_break :
  205. begin
  206. statement_syssym:=cbreaknode.create;
  207. pd:=voiddef;
  208. end;
  209. in_continue :
  210. begin
  211. statement_syssym:=ccontinuenode.create;
  212. pd:=voiddef;
  213. end;
  214. in_typeof_x :
  215. begin
  216. consume(_LKLAMMER);
  217. in_args:=true;
  218. {allow_type:=true;}
  219. p1:=comp_expr(true);
  220. {allow_type:=false;}
  221. consume(_RKLAMMER);
  222. pd:=voidpointerdef;
  223. if p1.nodetype=typen then
  224. begin
  225. if (ttypenode(p1).typenodetype=nil) then
  226. begin
  227. Message(type_e_mismatch);
  228. statement_syssym:=cerrornode.create;
  229. end
  230. else
  231. if ttypenode(p1).typenodetype^.deftype=objectdef then
  232. begin
  233. { we can use resulttype in pass_2 (PM) }
  234. p1.resulttype:=ttypenode(p1).typenodetype;
  235. statement_syssym:=geninlinenode(in_typeof_x,false,p1);
  236. end
  237. else
  238. begin
  239. Message(type_e_mismatch);
  240. p1.destroy;
  241. statement_syssym:=cerrornode.create;
  242. end;
  243. end
  244. else { not a type node }
  245. begin
  246. do_firstpass(p1);
  247. set_varstate(p1,false);
  248. if (p1.resulttype=nil) then
  249. begin
  250. Message(type_e_mismatch);
  251. p1.destroy;
  252. statement_syssym:=cerrornode.create;
  253. end
  254. else
  255. if p1.resulttype^.deftype=objectdef then
  256. statement_syssym:=geninlinenode(in_typeof_x,false,p1)
  257. else
  258. begin
  259. Message(type_e_mismatch);
  260. statement_syssym:=cerrornode.create;
  261. p1.destroy;
  262. end;
  263. end;
  264. end;
  265. in_sizeof_x :
  266. begin
  267. consume(_LKLAMMER);
  268. in_args:=true;
  269. {allow_type:=true;}
  270. p1:=comp_expr(true);
  271. {allow_type:=false; }
  272. consume(_RKLAMMER);
  273. pd:=s32bitdef;
  274. if p1.nodetype=typen then
  275. begin
  276. statement_syssym:=genordinalconstnode(ttypenode(p1).typenodetype^.size,pd);
  277. { p1 not needed !}
  278. p1.destroy;
  279. end
  280. else
  281. begin
  282. do_firstpass(p1);
  283. if ((p1.resulttype^.deftype=objectdef) and
  284. (oo_has_constructor in pobjectdef(p1.resulttype)^.objectoptions)) or
  285. is_open_array(p1.resulttype) or
  286. is_open_string(p1.resulttype) then
  287. statement_syssym:=geninlinenode(in_sizeof_x,false,p1)
  288. else
  289. begin
  290. statement_syssym:=genordinalconstnode(p1.resulttype^.size,pd);
  291. { p1 not needed !}
  292. p1.destroy;
  293. end;
  294. end;
  295. end;
  296. in_typeinfo_x :
  297. begin
  298. consume(_LKLAMMER);
  299. in_args:=true;
  300. {allow_type:=true;}
  301. p1:=comp_expr(true);
  302. do_firstpass(p1);
  303. {allow_type:=false; }
  304. if p1.nodetype<>typen then
  305. begin
  306. p1.destroy;
  307. p1:=cerrornode.create;
  308. Message(parser_e_illegal_parameter_list);
  309. end;
  310. consume(_RKLAMMER);
  311. p2:=gencallparanode(p1,nil);
  312. p2:=geninlinenode(in_typeinfo_x,false,p2);
  313. pd:=voidpointerdef;
  314. statement_syssym:=p2;
  315. end;
  316. in_assigned_x :
  317. begin
  318. consume(_LKLAMMER);
  319. in_args:=true;
  320. p1:=comp_expr(true);
  321. do_firstpass(p1);
  322. if not codegenerror then
  323. begin
  324. case p1.resulttype^.deftype of
  325. pointerdef,
  326. procvardef,
  327. classrefdef : ;
  328. objectdef :
  329. if not is_class_or_interface(p1.resulttype) then
  330. Message(parser_e_illegal_parameter_list);
  331. else
  332. Message(parser_e_illegal_parameter_list);
  333. end;
  334. end;
  335. p2:=gencallparanode(p1,nil);
  336. p2:=geninlinenode(in_assigned_x,false,p2);
  337. consume(_RKLAMMER);
  338. pd:=booldef;
  339. statement_syssym:=p2;
  340. end;
  341. in_addr_x :
  342. begin
  343. consume(_LKLAMMER);
  344. in_args:=true;
  345. p1:=comp_expr(true);
  346. p1:=caddrnode.create(p1);
  347. do_firstpass(p1);
  348. pd:=p1.resulttype;
  349. consume(_RKLAMMER);
  350. statement_syssym:=p1;
  351. end;
  352. in_ofs_x :
  353. begin
  354. consume(_LKLAMMER);
  355. in_args:=true;
  356. p1:=comp_expr(true);
  357. p1:=caddrnode.create(p1);
  358. do_firstpass(p1);
  359. { Ofs() returns a longint, not a pointer }
  360. p1.resulttype:=u32bitdef;
  361. pd:=p1.resulttype;
  362. consume(_RKLAMMER);
  363. statement_syssym:=p1;
  364. end;
  365. in_seg_x :
  366. begin
  367. consume(_LKLAMMER);
  368. in_args:=true;
  369. { the expression must be allowed to be assigned to }
  370. p1:=comp_expr(true);
  371. p1:=geninlinenode(in_assigned_x,false,p1);
  372. do_firstpass(p1);
  373. consume(_RKLAMMER);
  374. statement_syssym:=p1;
  375. end;
  376. in_high_x,
  377. in_low_x :
  378. begin
  379. consume(_LKLAMMER);
  380. in_args:=true;
  381. {allow_type:=true;}
  382. p1:=comp_expr(true);
  383. {allow_type:=false;}
  384. do_firstpass(p1);
  385. if p1.nodetype=typen then
  386. p1.resulttype:=ttypenode(p1).typenodetype;
  387. p2:=geninlinenode(l,false,p1);
  388. consume(_RKLAMMER);
  389. pd:=s32bitdef;
  390. statement_syssym:=p2;
  391. end;
  392. in_succ_x,
  393. in_pred_x :
  394. begin
  395. consume(_LKLAMMER);
  396. in_args:=true;
  397. p1:=comp_expr(true);
  398. do_firstpass(p1);
  399. p2:=geninlinenode(l,false,p1);
  400. consume(_RKLAMMER);
  401. pd:=p1.resulttype;
  402. statement_syssym:=p2;
  403. end;
  404. in_inc_x,
  405. in_dec_x :
  406. begin
  407. consume(_LKLAMMER);
  408. in_args:=true;
  409. p1:=comp_expr(true);
  410. if token=_COMMA then
  411. begin
  412. consume(_COMMA);
  413. p2:=gencallparanode(comp_expr(true),nil);
  414. end
  415. else
  416. p2:=nil;
  417. p2:=gencallparanode(p1,p2);
  418. statement_syssym:=geninlinenode(l,false,p2);
  419. consume(_RKLAMMER);
  420. pd:=voiddef;
  421. end;
  422. in_finalize_x:
  423. begin
  424. consume(_LKLAMMER);
  425. in_args:=true;
  426. p1:=comp_expr(true);
  427. if token=_COMMA then
  428. begin
  429. consume(_COMMA);
  430. p2:=gencallparanode(comp_expr(true),nil);
  431. end
  432. else
  433. p2:=nil;
  434. p2:=gencallparanode(p1,p2);
  435. statement_syssym:=geninlinenode(in_finalize_x,false,p2);
  436. consume(_RKLAMMER);
  437. pd:=voiddef;
  438. end;
  439. in_concat_x :
  440. begin
  441. consume(_LKLAMMER);
  442. in_args:=true;
  443. p2:=nil;
  444. while true do
  445. begin
  446. p1:=comp_expr(true);
  447. do_firstpass(p1);
  448. set_varstate(p1,true);
  449. if not((p1.resulttype^.deftype=stringdef) or
  450. ((p1.resulttype^.deftype=orddef) and
  451. (porddef(p1.resulttype)^.typ=uchar))) then
  452. Message(parser_e_illegal_parameter_list);
  453. if p2<>nil then
  454. p2:=caddnode.create(addn,p2,p1)
  455. else
  456. p2:=p1;
  457. if token=_COMMA then
  458. consume(_COMMA)
  459. else
  460. break;
  461. end;
  462. consume(_RKLAMMER);
  463. pd:=cshortstringdef;
  464. statement_syssym:=p2;
  465. end;
  466. in_read_x,
  467. in_readln_x :
  468. begin
  469. if token=_LKLAMMER then
  470. begin
  471. consume(_LKLAMMER);
  472. in_args:=true;
  473. paras:=parse_paras(false,false);
  474. consume(_RKLAMMER);
  475. end
  476. else
  477. paras:=nil;
  478. pd:=voiddef;
  479. p1:=geninlinenode(l,false,paras);
  480. do_firstpass(p1);
  481. statement_syssym := p1;
  482. end;
  483. in_setlength_x:
  484. begin
  485. if token=_LKLAMMER then
  486. begin
  487. consume(_LKLAMMER);
  488. in_args:=true;
  489. paras:=parse_paras(false,false);
  490. consume(_RKLAMMER);
  491. end
  492. else
  493. paras:=nil;
  494. pd:=voiddef;
  495. p1:=geninlinenode(l,false,paras);
  496. do_firstpass(p1);
  497. statement_syssym := p1;
  498. end;
  499. in_write_x,
  500. in_writeln_x :
  501. begin
  502. if token=_LKLAMMER then
  503. begin
  504. consume(_LKLAMMER);
  505. in_args:=true;
  506. paras:=parse_paras(true,false);
  507. consume(_RKLAMMER);
  508. end
  509. else
  510. paras:=nil;
  511. pd:=voiddef;
  512. p1 := geninlinenode(l,false,paras);
  513. do_firstpass(p1);
  514. statement_syssym := p1;
  515. end;
  516. in_str_x_string :
  517. begin
  518. consume(_LKLAMMER);
  519. in_args:=true;
  520. paras:=parse_paras(true,false);
  521. consume(_RKLAMMER);
  522. p1 := geninlinenode(l,false,paras);
  523. do_firstpass(p1);
  524. statement_syssym := p1;
  525. pd:=voiddef;
  526. end;
  527. in_val_x:
  528. Begin
  529. consume(_LKLAMMER);
  530. in_args := true;
  531. p1:= gencallparanode(comp_expr(true), nil);
  532. consume(_COMMA);
  533. p2 := gencallparanode(comp_expr(true),p1);
  534. if (token = _COMMA) then
  535. Begin
  536. consume(_COMMA);
  537. p2 := gencallparanode(comp_expr(true),p2)
  538. End;
  539. consume(_RKLAMMER);
  540. p2 := geninlinenode(l,false,p2);
  541. do_firstpass(p2);
  542. statement_syssym := p2;
  543. pd := voiddef;
  544. End;
  545. in_include_x_y,
  546. in_exclude_x_y :
  547. begin
  548. consume(_LKLAMMER);
  549. in_args:=true;
  550. p1:=comp_expr(true);
  551. consume(_COMMA);
  552. p2:=comp_expr(true);
  553. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  554. consume(_RKLAMMER);
  555. pd:=voiddef;
  556. end;
  557. in_assert_x_y :
  558. begin
  559. consume(_LKLAMMER);
  560. in_args:=true;
  561. p1:=comp_expr(true);
  562. if token=_COMMA then
  563. begin
  564. consume(_COMMA);
  565. p2:=comp_expr(true);
  566. end
  567. else
  568. begin
  569. { then insert an empty string }
  570. p2:=genstringconstnode('',st_default);
  571. end;
  572. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  573. consume(_RKLAMMER);
  574. pd:=voiddef;
  575. end;
  576. else
  577. internalerror(15);
  578. end;
  579. in_args:=prev_in_args;
  580. end;
  581. { reads the parameter for a subroutine call }
  582. procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:tcallnode;var pd:Pdef);
  583. var
  584. prev_in_args : boolean;
  585. prevafterassn : boolean;
  586. hs,hs1 : pvarsym;
  587. st : psymtable;
  588. p2 : tnode;
  589. begin
  590. prev_in_args:=in_args;
  591. prevafterassn:=afterassignment;
  592. afterassignment:=false;
  593. { want we only determine the address of }
  594. { a subroutine ? }
  595. if not(getaddr) then
  596. begin
  597. if auto_inherited then
  598. begin
  599. st:=symtablestack;
  600. while assigned(st) and (st^.symtabletype<>parasymtable) do
  601. st:=st^.next;
  602. p2:=nil;
  603. if assigned(st) then
  604. begin
  605. hs:=pvarsym(st^.symindex^.first);
  606. while assigned(hs) do
  607. begin
  608. if hs^.typ<>varsym then
  609. internalerror(54382953);
  610. { if there is a localcopy then use that }
  611. if assigned(hs^.localvarsym) then
  612. hs1:=hs^.localvarsym
  613. else
  614. hs1:=hs;
  615. p2:=gencallparanode(genloadnode(hs1,hs1^.owner),p2);
  616. hs:=pvarsym(hs^.indexnext);
  617. end;
  618. end
  619. else
  620. internalerror(54382954);
  621. p1.left:=p2;
  622. end
  623. else
  624. begin
  625. if token=_LKLAMMER then
  626. begin
  627. consume(_LKLAMMER);
  628. in_args:=true;
  629. p1.left:=parse_paras(false,false);
  630. consume(_RKLAMMER);
  631. end
  632. else
  633. p1.left:=nil;
  634. end;
  635. { do firstpass because we need the }
  636. { result type }
  637. do_firstpass(p1);
  638. {set_var_state is handled inside firstcalln }
  639. end
  640. else
  641. begin
  642. { address operator @: }
  643. p1.left:=nil;
  644. { forget pd }
  645. pd:=nil;
  646. if (p1.symtableproc^.symtabletype=withsymtable) and
  647. (p1.symtableproc^.defowner^.deftype=objectdef) then
  648. begin
  649. p1.methodpointer:=tnode(pwithsymtable(p1.symtableproc)^.withrefnode).getcopy;
  650. end
  651. else if not(assigned(p1.methodpointer)) then
  652. begin
  653. { we must provide a method pointer, if it isn't given, }
  654. { it is self }
  655. if assigned(procinfo) then
  656. begin
  657. p1.methodpointer:=genselfnode(procinfo^._class);
  658. p1.methodpointer.resulttype:=procinfo^._class;
  659. end
  660. else
  661. begin
  662. p1.methodpointer:=genselfnode(nil);
  663. p1.methodpointer.resulttype:=nil;
  664. end;
  665. end;
  666. { no postfix operators }
  667. again:=false;
  668. end;
  669. pd:=p1.resulttype;
  670. in_args:=prev_in_args;
  671. afterassignment:=prevafterassn;
  672. end;
  673. procedure handle_procvar(pv : pprocvardef;var p2 : tnode);
  674. procedure doconv(procvar : pprocvardef;var t : tnode);
  675. var
  676. hp : tnode;
  677. begin
  678. hp:=nil;
  679. if (proc_to_procvar_equal(pprocsym(tcallnode(t).symtableprocentry)^.definition,procvar)) then
  680. begin
  681. if (po_methodpointer in procvar^.procoptions) then
  682. hp:=genloadmethodcallnode(pprocsym(tcallnode(t).symtableprocentry),tcallnode(t).symtableproc,tnode(tcallnode(t).methodpointer).getcopy)
  683. else
  684. hp:=genloadcallnode(pprocsym(tcallnode(t).symtableprocentry),tcallnode(t).symtableproc);
  685. end;
  686. if assigned(hp) then
  687. begin
  688. t.destroy;
  689. t:=hp;
  690. end;
  691. end;
  692. begin
  693. if (p2.nodetype=calln) then
  694. doconv(pv,tcallnode(p2))
  695. else
  696. if (p2.nodetype=typeconvn) and
  697. (ttypeconvnode(p2).left.nodetype=calln) then
  698. doconv(pv,tcallnode(ttypeconvnode(p2).left));
  699. end;
  700. { the following procedure handles the access to a property symbol }
  701. procedure handle_propertysym(sym : psym;st : psymtable;var p1 : tnode;
  702. var pd : pdef);
  703. var
  704. paras : tnode;
  705. p2 : tnode;
  706. plist : psymlistitem;
  707. begin
  708. paras:=nil;
  709. { property parameters? read them only if the property really }
  710. { has parameters }
  711. if ppo_hasparameters in ppropertysym(sym)^.propoptions then
  712. begin
  713. if token=_LECKKLAMMER then
  714. begin
  715. consume(_LECKKLAMMER);
  716. paras:=parse_paras(false,true);
  717. consume(_RECKKLAMMER);
  718. end;
  719. { indexed property }
  720. if (ppo_indexed in ppropertysym(sym)^.propoptions) then
  721. begin
  722. p2:=genordinalconstnode(ppropertysym(sym)^.index,ppropertysym(sym)^.indextype.def);
  723. paras:=gencallparanode(p2,paras);
  724. end;
  725. end;
  726. { we need only a write property if a := follows }
  727. { if not(afterassignment) and not(in_args) then }
  728. if token=_ASSIGNMENT then
  729. begin
  730. { write property: }
  731. { no result }
  732. pd:=voiddef;
  733. if not ppropertysym(sym)^.writeaccess^.empty then
  734. begin
  735. case ppropertysym(sym)^.writeaccess^.firstsym^.sym^.typ of
  736. procsym :
  737. begin
  738. { generate the method call }
  739. p1:=ccallnode.create(pprocsym(ppropertysym(sym)^.writeaccess^.firstsym^.sym),st,p1);
  740. { we know the procedure to call, so
  741. force the usage of that procedure }
  742. tcallnode(p1).procdefinition:=pprocdef(ppropertysym(sym)^.writeaccess^.def);
  743. tcallnode(p1).left:=paras;
  744. consume(_ASSIGNMENT);
  745. { read the expression }
  746. getprocvar:=ppropertysym(sym)^.proptype.def^.deftype=procvardef;
  747. p2:=comp_expr(true);
  748. if getprocvar then
  749. handle_procvar(pprocvardef(ppropertysym(sym)^.proptype.def),p2);
  750. tcallnode(p1).left:=gencallparanode(p2,tcallnode(p1).left);
  751. include(tcallnode(p1).flags,nf_isproperty);
  752. getprocvar:=false;
  753. end;
  754. varsym :
  755. begin
  756. if assigned(paras) then
  757. message(parser_e_no_paras_allowed);
  758. { subscribed access? }
  759. plist:=ppropertysym(sym)^.writeaccess^.firstsym;
  760. while assigned(plist) do
  761. begin
  762. if p1=nil then
  763. p1:=genloadnode(pvarsym(plist^.sym),st)
  764. else
  765. p1:=gensubscriptnode(pvarsym(plist^.sym),p1);
  766. plist:=plist^.next;
  767. end;
  768. include(tcallnode(p1).flags,nf_isproperty);
  769. consume(_ASSIGNMENT);
  770. { read the expression }
  771. p2:=comp_expr(true);
  772. p1:=cassignmentnode.create(p1,p2);
  773. end
  774. else
  775. begin
  776. p1:=cerrornode.create;
  777. Message(parser_e_no_procedure_to_access_property);
  778. end;
  779. end;
  780. end
  781. else
  782. begin
  783. p1:=cerrornode.create;
  784. Message(parser_e_no_procedure_to_access_property);
  785. end;
  786. end
  787. else
  788. begin
  789. { read property: }
  790. pd:=ppropertysym(sym)^.proptype.def;
  791. if not ppropertysym(sym)^.readaccess^.empty then
  792. begin
  793. case ppropertysym(sym)^.readaccess^.firstsym^.sym^.typ of
  794. varsym :
  795. begin
  796. if assigned(paras) then
  797. message(parser_e_no_paras_allowed);
  798. { subscribed access? }
  799. plist:=ppropertysym(sym)^.readaccess^.firstsym;
  800. while assigned(plist) do
  801. begin
  802. if p1=nil then
  803. p1:=genloadnode(pvarsym(plist^.sym),st)
  804. else
  805. p1:=gensubscriptnode(pvarsym(plist^.sym),p1);
  806. plist:=plist^.next;
  807. end;
  808. include(p1.flags,nf_isproperty);
  809. end;
  810. procsym :
  811. begin
  812. { generate the method call }
  813. p1:=ccallnode.create(pprocsym(ppropertysym(sym)^.readaccess^.firstsym^.sym),st,p1);
  814. { we know the procedure to call, so
  815. force the usage of that procedure }
  816. tcallnode(p1).procdefinition:=pprocdef(ppropertysym(sym)^.readaccess^.def);
  817. { insert paras }
  818. tcallnode(p1).left:=paras;
  819. include(p1.flags,nf_isproperty);
  820. end
  821. else
  822. begin
  823. p1:=cerrornode.create;
  824. Message(type_e_mismatch);
  825. end;
  826. end;
  827. end
  828. else
  829. begin
  830. { error, no function to read property }
  831. p1:=cerrornode.create;
  832. Message(parser_e_no_procedure_to_access_property);
  833. end;
  834. end;
  835. end;
  836. { the ID token has to be consumed before calling this function }
  837. procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : tnode;
  838. var pd : pdef;var again : boolean);
  839. var
  840. static_name : string;
  841. isclassref : boolean;
  842. objdef : pobjectdef;
  843. begin
  844. if sym=nil then
  845. begin
  846. { pattern is still valid unless
  847. there is another ID just after the ID of sym }
  848. Message1(sym_e_id_no_member,pattern);
  849. p1.destroy;
  850. p1:=cerrornode.create;
  851. { try to clean up }
  852. pd:=generrordef;
  853. again:=false;
  854. end
  855. else
  856. begin
  857. objdef:=pobjectdef(sym^.owner^.defowner);
  858. isclassref:=(pd^.deftype=classrefdef);
  859. { check protected and private members }
  860. { please leave this code as it is, }
  861. { it has now the same behaviaor as TP/Delphi }
  862. if (sp_private in sym^.symoptions) and
  863. (objdef^.owner^.symtabletype=unitsymtable) then
  864. Message(parser_e_cant_access_private_member);
  865. if (sp_protected in sym^.symoptions) and
  866. (objdef^.owner^.symtabletype=unitsymtable) then
  867. begin
  868. if assigned(aktprocsym^.definition^._class) then
  869. begin
  870. if not aktprocsym^.definition^._class^.is_related(objdef) then
  871. Message(parser_e_cant_access_protected_member);
  872. end
  873. else
  874. Message(parser_e_cant_access_protected_member);
  875. end;
  876. { we assume, that only procsyms and varsyms are in an object }
  877. { symbol table, for classes, properties are allowed }
  878. case sym^.typ of
  879. procsym:
  880. begin
  881. p1:=ccallnode.create(pprocsym(sym),sym^.owner,p1);
  882. do_proc_call(getaddr or
  883. (getprocvar and
  884. ((block_type=bt_const) or
  885. ((m_tp_procvar in aktmodeswitches) and
  886. proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef)
  887. )
  888. )
  889. ),again,tcallnode(p1),pd);
  890. if (block_type=bt_const) and
  891. getprocvar then
  892. handle_procvar(getprocvardef,p1);
  893. { now we know the real method e.g. we can check for a class method }
  894. if isclassref and
  895. assigned(tcallnode(p1).procdefinition) and
  896. not(po_classmethod in tcallnode(p1).procdefinition^.procoptions) and
  897. not(tcallnode(p1).procdefinition^.proctypeoption=potype_constructor) then
  898. Message(parser_e_only_class_methods_via_class_ref);
  899. end;
  900. varsym:
  901. begin
  902. if isclassref then
  903. Message(parser_e_only_class_methods_via_class_ref);
  904. if (sp_static in sym^.symoptions) then
  905. begin
  906. { static_name:=lower(srsymtable^.name^)+'_'+sym^.name;
  907. this is wrong for static field in with symtable (PM) }
  908. static_name:=lower(srsym^.owner^.name^)+'_'+sym^.name;
  909. getsym(static_name,true);
  910. p1.destroy;
  911. p1:=genloadnode(pvarsym(srsym),srsymtable);
  912. end
  913. else
  914. p1:=gensubscriptnode(pvarsym(sym),p1);
  915. pd:=pvarsym(sym)^.vartype.def;
  916. end;
  917. propertysym:
  918. begin
  919. if isclassref then
  920. Message(parser_e_only_class_methods_via_class_ref);
  921. handle_propertysym(sym,srsymtable,p1,pd);
  922. end;
  923. else internalerror(16);
  924. end;
  925. end;
  926. end;
  927. {****************************************************************************
  928. Factor
  929. ****************************************************************************}
  930. {$ifdef fpc}
  931. {$maxfpuregisters 0}
  932. {$endif fpc}
  933. function factor(getaddr : boolean) : tnode;
  934. var
  935. l : longint;
  936. card : cardinal;
  937. ic : TConstExprInt;
  938. oldp1,
  939. p1,p2,p3 : tnode;
  940. code : integer;
  941. pd,pd2 : pdef;
  942. possible_error,
  943. {$ifdef TEST_PROCSYMS}
  944. unit_specific,
  945. {$endif TEST_PROCSYMS}
  946. again : boolean;
  947. sym : psym;
  948. classh : pobjectdef;
  949. d : bestreal;
  950. hs,
  951. static_name : string;
  952. propsym : ppropertysym;
  953. filepos : tfileposinfo;
  954. {---------------------------------------------
  955. Is_func_ret
  956. ---------------------------------------------}
  957. function is_func_ret(sym : psym) : boolean;
  958. var
  959. p : pprocinfo;
  960. storesymtablestack : psymtable;
  961. begin
  962. is_func_ret:=false;
  963. if not assigned(procinfo) or
  964. ((sym^.typ<>funcretsym) and ((procinfo^.flags and pi_operator)=0)) then
  965. exit;
  966. p:=procinfo;
  967. while assigned(p) do
  968. begin
  969. { is this an access to a function result? Accessing _RESULT is
  970. always allowed and funcretn is generated }
  971. if assigned(p^.funcretsym) and
  972. ((pfuncretsym(sym)=p^.resultfuncretsym) or
  973. ((pfuncretsym(sym)=p^.funcretsym) or
  974. ((pvarsym(sym)=opsym) and ((p^.flags and pi_operator)<>0))) and
  975. (p^.returntype.def<>pdef(voiddef)) and
  976. (token<>_LKLAMMER) and
  977. (not ((m_tp in aktmodeswitches) and (afterassignment or in_args)))
  978. ) then
  979. begin
  980. if ((pvarsym(sym)=opsym) and
  981. ((p^.flags and pi_operator)<>0)) then
  982. inc(opsym^.refs);
  983. p1:=cfuncretnode.create;
  984. pd:=p^.returntype.def;
  985. tfuncretnode(p1).funcretprocinfo:=p;
  986. tfuncretnode(p1).rettype.def:=pd;
  987. is_func_ret:=true;
  988. if p^.funcret_state=vs_declared then
  989. begin
  990. p^.funcret_state:=vs_declared_and_first_found;
  991. include(p1.flags,nf_is_first_funcret);
  992. end;
  993. exit;
  994. end;
  995. p:=p^.parent;
  996. end;
  997. { we must use the function call }
  998. if (sym^.typ=funcretsym) then
  999. begin
  1000. storesymtablestack:=symtablestack;
  1001. symtablestack:=srsymtable^.next;
  1002. getsym(sym^.name,true);
  1003. if srsym^.typ<>procsym then
  1004. Message(cg_e_illegal_expression);
  1005. symtablestack:=storesymtablestack;
  1006. end;
  1007. end;
  1008. {---------------------------------------------
  1009. Factor_read_id
  1010. ---------------------------------------------}
  1011. procedure factor_read_id;
  1012. var
  1013. pc : pchar;
  1014. len : longint;
  1015. begin
  1016. { allow post fix operators }
  1017. again:=true;
  1018. begin
  1019. if lastsymknown then
  1020. begin
  1021. srsym:=lastsrsym;
  1022. srsymtable:=lastsrsymtable;
  1023. lastsymknown:=false;
  1024. end
  1025. else
  1026. getsym(pattern,true);
  1027. consume(_ID);
  1028. if not is_func_ret(srsym) then
  1029. { else it's a normal symbol }
  1030. begin
  1031. { is it defined like UNIT.SYMBOL ? }
  1032. if srsym^.typ=unitsym then
  1033. begin
  1034. consume(_POINT);
  1035. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  1036. {$ifdef TEST_PROCSYMS}
  1037. unit_specific:=true;
  1038. {$endif TEST_PROCSYMS}
  1039. consume(_ID);
  1040. {$ifdef TEST_PROCSYMS}
  1041. end
  1042. else
  1043. unit_specific:=false;
  1044. {$else TEST_PROCSYMS}
  1045. end;
  1046. {$endif TEST_PROCSYMS}
  1047. if not assigned(srsym) then
  1048. Begin
  1049. p1:=cerrornode.create;
  1050. { try to clean up }
  1051. pd:=generrordef;
  1052. end
  1053. else
  1054. Begin
  1055. { check semantics of private }
  1056. if (srsym^.typ in [propertysym,procsym,varsym]) and
  1057. (srsymtable^.symtabletype=objectsymtable) then
  1058. begin
  1059. if (sp_private in srsym^.symoptions) and
  1060. (pobjectdef(srsym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then
  1061. Message(parser_e_cant_access_private_member);
  1062. end;
  1063. case srsym^.typ of
  1064. absolutesym : begin
  1065. p1:=genloadnode(pvarsym(srsym),srsymtable);
  1066. pd:=pabsolutesym(srsym)^.vartype.def;
  1067. end;
  1068. varsym : begin
  1069. { are we in a class method ? }
  1070. if (srsymtable^.symtabletype=objectsymtable) and
  1071. assigned(aktprocsym) and
  1072. (po_classmethod in aktprocsym^.definition^.procoptions) then
  1073. Message(parser_e_only_class_methods);
  1074. if (sp_static in srsym^.symoptions) then
  1075. begin
  1076. static_name:=lower(srsym^.owner^.name^)+'_'+srsym^.name;
  1077. getsym(static_name,true);
  1078. end;
  1079. p1:=genloadnode(pvarsym(srsym),srsymtable);
  1080. if pvarsym(srsym)^.varstate=vs_declared then
  1081. begin
  1082. include(p1.flags,nf_first);
  1083. { set special between first loaded until checked in firstpass }
  1084. pvarsym(srsym)^.varstate:=vs_declared_and_first_found;
  1085. end;
  1086. pd:=pvarsym(srsym)^.vartype.def;
  1087. end;
  1088. typedconstsym : begin
  1089. p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
  1090. pd:=ptypedconstsym(srsym)^.typedconsttype.def;
  1091. end;
  1092. syssym : p1:=statement_syssym(psyssym(srsym)^.number,pd);
  1093. typesym : begin
  1094. pd:=ptypesym(srsym)^.restype.def;
  1095. if not assigned(pd) then
  1096. begin
  1097. pd:=generrordef;
  1098. again:=false;
  1099. end
  1100. else
  1101. begin
  1102. { if we read a type declaration }
  1103. { we have to return the type and }
  1104. { nothing else }
  1105. if block_type=bt_type then
  1106. begin
  1107. { we don't need sym reference when it's in the
  1108. current unit or system unit, because those
  1109. units are always loaded (PFV) }
  1110. if not(assigned(pd^.owner)) or
  1111. (pd^.owner^.unitid=0) or
  1112. (pd^.owner^.unitid=1) then
  1113. p1:=gentypenode(pd,nil)
  1114. else
  1115. p1:=gentypenode(pd,ptypesym(srsym));
  1116. { here we can also set resulttype !! }
  1117. p1.resulttype:=pd;
  1118. pd:=voiddef;
  1119. end
  1120. else { not type block }
  1121. begin
  1122. if token=_LKLAMMER then
  1123. begin
  1124. consume(_LKLAMMER);
  1125. p1:=comp_expr(true);
  1126. consume(_RKLAMMER);
  1127. p1:=gentypeconvnode(p1,pd);
  1128. include(p1.flags,nf_explizit);
  1129. end
  1130. else { not LKLAMMER }
  1131. if (token=_POINT) and
  1132. is_object(pd) then
  1133. begin
  1134. consume(_POINT);
  1135. if assigned(procinfo) and
  1136. assigned(procinfo^._class) and
  1137. not(getaddr) then
  1138. begin
  1139. if procinfo^._class^.is_related(pobjectdef(pd)) then
  1140. begin
  1141. p1:=gentypenode(pd,ptypesym(srsym));
  1142. p1.resulttype:=pd;
  1143. { search also in inherited methods }
  1144. repeat
  1145. srsymtable:=pobjectdef(pd)^.symtable;
  1146. sym:=pvarsym(srsymtable^.search(pattern));
  1147. if assigned(sym) then
  1148. break;
  1149. pd:=pobjectdef(pd)^.childof;
  1150. until not assigned(pd);
  1151. consume(_ID);
  1152. do_member_read(false,sym,p1,pd,again);
  1153. end
  1154. else
  1155. begin
  1156. Message(parser_e_no_super_class);
  1157. pd:=generrordef;
  1158. again:=false;
  1159. end;
  1160. end
  1161. else
  1162. begin
  1163. { allows @TObject.Load }
  1164. { also allows static methods and variables }
  1165. p1:=ctypenode.create(nil,nil);
  1166. p1.resulttype:=pd;
  1167. { TP allows also @TMenu.Load if Load is only }
  1168. { defined in an anchestor class }
  1169. sym:=pvarsym(search_class_member(pobjectdef(pd),pattern));
  1170. if not assigned(sym) then
  1171. Message1(sym_e_id_no_member,pattern)
  1172. else if not(getaddr) and not(sp_static in sym^.symoptions) then
  1173. Message(sym_e_only_static_in_static)
  1174. else
  1175. begin
  1176. consume(_ID);
  1177. do_member_read(getaddr,sym,p1,pd,again);
  1178. end;
  1179. end;
  1180. end
  1181. else
  1182. begin
  1183. { class reference ? }
  1184. if is_class(pd) then
  1185. begin
  1186. if getaddr and (token=_POINT) then
  1187. begin
  1188. consume(_POINT);
  1189. { allows @Object.Method }
  1190. { also allows static methods and variables }
  1191. p1:=gentypenode(nil,nil);
  1192. p1.resulttype:=pd;
  1193. { TP allows also @TMenu.Load if Load is only }
  1194. { defined in an anchestor class }
  1195. sym:=pvarsym(search_class_member(pobjectdef(pd),pattern));
  1196. if not assigned(sym) then
  1197. Message1(sym_e_id_no_member,pattern)
  1198. else
  1199. begin
  1200. consume(_ID);
  1201. do_member_read(getaddr,sym,p1,pd,again);
  1202. end;
  1203. end
  1204. else
  1205. begin
  1206. p1:=gentypenode(pd,nil);
  1207. p1.resulttype:=pd;
  1208. pd:=new(pclassrefdef,init(pd));
  1209. p1:=cloadvmtnode.create(p1);
  1210. p1.resulttype:=pd;
  1211. end;
  1212. end
  1213. else
  1214. begin
  1215. { generate a type node }
  1216. { (for typeof etc) }
  1217. if allow_type then
  1218. begin
  1219. p1:=gentypenode(pd,nil);
  1220. { here we must use typenodetype explicitly !! PM
  1221. p1.resulttype:=pd; }
  1222. pd:=voiddef;
  1223. end
  1224. else
  1225. Message(parser_e_no_type_not_allowed_here);
  1226. end;
  1227. end;
  1228. end;
  1229. end;
  1230. end;
  1231. enumsym : begin
  1232. p1:=genenumnode(penumsym(srsym));
  1233. pd:=p1.resulttype;
  1234. end;
  1235. constsym : begin
  1236. case pconstsym(srsym)^.consttyp of
  1237. constint :
  1238. { do a very dirty trick to bootstrap this code }
  1239. if (pconstsym(srsym)^.value>=-(int64(2147483647)+int64(1))) and (pconstsym(srsym)^.value<=2147483647) then
  1240. p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef)
  1241. else
  1242. p1:=genordinalconstnode(pconstsym(srsym)^.value,cs64bitdef);
  1243. conststring :
  1244. begin
  1245. len:=pconstsym(srsym)^.len;
  1246. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  1247. len:=255;
  1248. getmem(pc,len+1);
  1249. move(pchar(tpointerord(pconstsym(srsym)^.value))^,pc^,len);
  1250. pc[len]:=#0;
  1251. p1:=genpcharconstnode(pc,len);
  1252. end;
  1253. constchar :
  1254. p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
  1255. constreal :
  1256. p1:=genrealconstnode(pbestreal(tpointerord(pconstsym(srsym)^.value))^,bestrealdef^);
  1257. constbool :
  1258. p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
  1259. constset :
  1260. p1:=gensetconstnode(pconstset(tpointerord(pconstsym(srsym)^.value)),
  1261. psetdef(pconstsym(srsym)^.consttype.def));
  1262. constord :
  1263. p1:=genordinalconstnode(pconstsym(srsym)^.value,
  1264. pconstsym(srsym)^.consttype.def);
  1265. constpointer :
  1266. p1:=genpointerconstnode(pconstsym(srsym)^.value,
  1267. pconstsym(srsym)^.consttype.def);
  1268. constnil :
  1269. p1:=cnilnode.create;
  1270. constresourcestring:
  1271. begin
  1272. p1:=genloadnode(pvarsym(srsym),srsymtable);
  1273. p1.resulttype:=cansistringdef;
  1274. end;
  1275. end;
  1276. pd:=p1.resulttype;
  1277. end;
  1278. procsym : begin
  1279. { are we in a class method ? }
  1280. possible_error:=(srsymtable^.symtabletype=objectsymtable) and
  1281. assigned(aktprocsym) and
  1282. (po_classmethod in aktprocsym^.definition^.procoptions);
  1283. p1:=gencallnode(pprocsym(srsym),srsymtable);
  1284. {$ifdef TEST_PROCSYMS}
  1285. p1.unit_specific:=unit_specific;
  1286. {$endif TEST_PROCSYMS}
  1287. do_proc_call(getaddr or
  1288. (getprocvar and
  1289. ((block_type=bt_const) or
  1290. ((m_tp_procvar in aktmodeswitches) and
  1291. proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)
  1292. )
  1293. )
  1294. ),again,tcallnode(p1),pd);
  1295. if (block_type=bt_const) and
  1296. getprocvar then
  1297. handle_procvar(getprocvardef,p1);
  1298. if possible_error and
  1299. not(po_classmethod in tcallnode(p1).procdefinition^.procoptions) then
  1300. Message(parser_e_only_class_methods);
  1301. end;
  1302. propertysym : begin
  1303. { access to property in a method }
  1304. { are we in a class method ? }
  1305. if (srsymtable^.symtabletype=objectsymtable) and
  1306. assigned(aktprocsym) and
  1307. (po_classmethod in aktprocsym^.definition^.procoptions) then
  1308. Message(parser_e_only_class_methods);
  1309. { no method pointer }
  1310. p1:=nil;
  1311. handle_propertysym(srsym,srsymtable,p1,pd);
  1312. end;
  1313. errorsym : begin
  1314. p1:=cerrornode.create;
  1315. p1.resulttype:=generrordef;
  1316. pd:=generrordef;
  1317. if token=_LKLAMMER then
  1318. begin
  1319. consume(_LKLAMMER);
  1320. parse_paras(false,false);
  1321. consume(_RKLAMMER);
  1322. end;
  1323. end;
  1324. else
  1325. begin
  1326. p1:=cerrornode.create;
  1327. pd:=generrordef;
  1328. Message(cg_e_illegal_expression);
  1329. end;
  1330. end; { end case }
  1331. end;
  1332. end;
  1333. end;
  1334. end;
  1335. {---------------------------------------------
  1336. Factor_Read_Set
  1337. ---------------------------------------------}
  1338. { Read a set between [] }
  1339. function factor_read_set:tnode;
  1340. var
  1341. p1 : tnode;
  1342. lastp,
  1343. buildp : tarrayconstructornode;
  1344. begin
  1345. buildp:=nil;
  1346. { be sure that a least one arrayconstructn is used, also for an
  1347. empty [] }
  1348. if token=_RECKKLAMMER then
  1349. buildp:=carrayconstructornode.create(nil,buildp)
  1350. else
  1351. begin
  1352. while true do
  1353. begin
  1354. p1:=comp_expr(true);
  1355. if token=_POINTPOINT then
  1356. begin
  1357. consume(_POINTPOINT);
  1358. p2:=comp_expr(true);
  1359. p1:=carrayconstructorrangenode.create(p1,p2);
  1360. end;
  1361. { insert at the end of the tree, to get the correct order }
  1362. if not assigned(buildp) then
  1363. begin
  1364. buildp:=carrayconstructornode.create(p1,nil);
  1365. lastp:=buildp;
  1366. end
  1367. else
  1368. begin
  1369. lastp.right:=carrayconstructornode.create(p1,nil);
  1370. lastp:=tarrayconstructornode(lastp.right);
  1371. end;
  1372. { there could be more elements }
  1373. if token=_COMMA then
  1374. consume(_COMMA)
  1375. else
  1376. break;
  1377. end;
  1378. end;
  1379. factor_read_set:=buildp;
  1380. end;
  1381. {---------------------------------------------
  1382. Helpers
  1383. ---------------------------------------------}
  1384. procedure check_tokenpos;
  1385. begin
  1386. if (p1<>oldp1) then
  1387. begin
  1388. if assigned(p1) then
  1389. p1.set_tree_filepos(filepos);
  1390. oldp1:=p1;
  1391. filepos:=akttokenpos;
  1392. end;
  1393. end;
  1394. {---------------------------------------------
  1395. PostFixOperators
  1396. ---------------------------------------------}
  1397. procedure postfixoperators;
  1398. { tries to avoid syntax errors after invalid qualifiers }
  1399. procedure recoverconsume_postfixops;
  1400. begin
  1401. while true do
  1402. begin
  1403. case token of
  1404. _CARET:
  1405. consume(_CARET);
  1406. _POINT:
  1407. begin
  1408. consume(_POINT);
  1409. if token=_ID then
  1410. consume(_ID);
  1411. end;
  1412. _LECKKLAMMER:
  1413. begin
  1414. consume(_LECKKLAMMER);
  1415. repeat
  1416. comp_expr(true);
  1417. if token=_COMMA then
  1418. consume(_COMMA)
  1419. else
  1420. break;
  1421. until false;
  1422. consume(_RECKKLAMMER);
  1423. end
  1424. else
  1425. break;
  1426. end;
  1427. end;
  1428. end;
  1429. var
  1430. store_static : boolean;
  1431. { p1 and p2 must contain valid value_str }
  1432. begin
  1433. check_tokenpos;
  1434. while again do
  1435. begin
  1436. { prevent crashes with unknown types }
  1437. if not assigned(pd) then
  1438. begin
  1439. recoverconsume_postfixops;
  1440. exit;
  1441. end;
  1442. { handle token }
  1443. case token of
  1444. _CARET:
  1445. begin
  1446. consume(_CARET);
  1447. if (pd^.deftype<>pointerdef) then
  1448. begin
  1449. { ^ as binary operator is a problem!!!! (FK) }
  1450. again:=false;
  1451. Message(cg_e_invalid_qualifier);
  1452. recoverconsume_postfixops;
  1453. p1.destroy;
  1454. p1:=cerrornode.create;
  1455. end
  1456. else
  1457. begin
  1458. p1:=cderefnode.create(p1);
  1459. pd:=ppointerdef(pd)^.pointertype.def;
  1460. end;
  1461. end;
  1462. _LECKKLAMMER:
  1463. begin
  1464. if is_class_or_interface(pd) then
  1465. begin
  1466. { default property }
  1467. propsym:=search_default_property(pobjectdef(pd));
  1468. if not(assigned(propsym)) then
  1469. begin
  1470. p1.destroy;
  1471. p1:=cerrornode.create;
  1472. again:=false;
  1473. message(parser_e_no_default_property_available);
  1474. end
  1475. else
  1476. handle_propertysym(propsym,propsym^.owner,p1,pd);
  1477. end
  1478. else
  1479. begin
  1480. consume(_LECKKLAMMER);
  1481. repeat
  1482. case pd^.deftype of
  1483. pointerdef:
  1484. begin
  1485. pd:=ppointerdef(pd)^.pointertype.def;
  1486. { support delphi autoderef }
  1487. if (pd^.deftype=arraydef) and
  1488. (m_autoderef in aktmodeswitches) then
  1489. begin
  1490. p1:=cderefnode.create(p1);
  1491. pd:=parraydef(pd)^.elementtype.def;
  1492. end;
  1493. p2:=comp_expr(true);
  1494. p1:=cvecnode.create(p1,p2);
  1495. end;
  1496. stringdef : begin
  1497. p2:=comp_expr(true);
  1498. p1:=cvecnode.create(p1,p2);
  1499. pd:=cchardef
  1500. end;
  1501. arraydef : begin
  1502. p2:=comp_expr(true);
  1503. { support SEG:OFS for go32v2 Mem[] }
  1504. if (target_info.target=target_i386_go32v2) and
  1505. (p1.nodetype=loadn) and
  1506. assigned(tloadnode(p1).symtableentry) and
  1507. assigned(tloadnode(p1).symtableentry^.owner^.name) and
  1508. (tloadnode(p1).symtableentry^.owner^.name^='SYSTEM') and
  1509. ((tloadnode(p1).symtableentry^.name='MEM') or
  1510. (tloadnode(p1).symtableentry^.name='MEMW') or
  1511. (tloadnode(p1).symtableentry^.name='MEML')) then
  1512. begin
  1513. if (token=_COLON) then
  1514. begin
  1515. consume(_COLON);
  1516. p3:=caddnode.create(muln,genordinalconstnode($10,s32bitdef),p2);
  1517. p2:=comp_expr(true);
  1518. p2:=caddnode.create(addn,p2,p3);
  1519. p1:=cvecnode.create(p1,p2);
  1520. include(tvecnode(p1).flags,nf_memseg);
  1521. include(tvecnode(p1).flags,nf_memindex);
  1522. end
  1523. else
  1524. begin
  1525. p1:=cvecnode.create(p1,p2);
  1526. include(tvecnode(p1).flags,nf_memindex);
  1527. end;
  1528. end
  1529. else
  1530. p1:=cvecnode.create(p1,p2);
  1531. pd:=parraydef(pd)^.elementtype.def;
  1532. end;
  1533. else
  1534. begin
  1535. Message(cg_e_invalid_qualifier);
  1536. p1.destroy;
  1537. p1:=cerrornode.create;
  1538. comp_expr(true);
  1539. again:=false;
  1540. end;
  1541. end;
  1542. if token=_COMMA then
  1543. consume(_COMMA)
  1544. else
  1545. break;
  1546. until false;
  1547. consume(_RECKKLAMMER);
  1548. end;
  1549. end;
  1550. _POINT : begin
  1551. consume(_POINT);
  1552. if (pd^.deftype=pointerdef) and
  1553. (m_autoderef in aktmodeswitches) then
  1554. begin
  1555. p1:=cderefnode.create(p1);
  1556. pd:=ppointerdef(pd)^.pointertype.def;
  1557. end;
  1558. case pd^.deftype of
  1559. recorddef:
  1560. begin
  1561. sym:=psym(precorddef(pd)^.symtable^.search(pattern));
  1562. if assigned(sym) and
  1563. (sym^.typ=varsym) then
  1564. begin
  1565. p1:=gensubscriptnode(pvarsym(sym),p1);
  1566. pd:=pvarsym(sym)^.vartype.def;
  1567. end
  1568. else
  1569. begin
  1570. Message1(sym_e_illegal_field,pattern);
  1571. p1.destroy;
  1572. p1:=cerrornode.create;
  1573. end;
  1574. consume(_ID);
  1575. end;
  1576. classrefdef:
  1577. begin
  1578. classh:=pobjectdef(pclassrefdef(pd)^.pointertype.def);
  1579. sym:=nil;
  1580. while assigned(classh) do
  1581. begin
  1582. sym:=psym(classh^.symtable^.search(pattern));
  1583. srsymtable:=classh^.symtable;
  1584. if assigned(sym) then
  1585. break;
  1586. classh:=classh^.childof;
  1587. end;
  1588. if sym=nil then
  1589. begin
  1590. Message1(sym_e_id_no_member,pattern);
  1591. p1.destroy;
  1592. p1:=cerrornode.create;
  1593. { try to clean up }
  1594. pd:=generrordef;
  1595. consume(_ID);
  1596. end
  1597. else
  1598. begin
  1599. consume(_ID);
  1600. do_member_read(getaddr,sym,p1,pd,again);
  1601. end;
  1602. end;
  1603. objectdef:
  1604. begin
  1605. classh:=pobjectdef(pd);
  1606. sym:=nil;
  1607. store_static:=allow_only_static;
  1608. allow_only_static:=false;
  1609. while assigned(classh) do
  1610. begin
  1611. sym:=psym(classh^.symtable^.search(pattern));
  1612. srsymtable:=classh^.symtable;
  1613. if assigned(sym) then
  1614. break;
  1615. classh:=classh^.childof;
  1616. end;
  1617. allow_only_static:=store_static;
  1618. if sym=nil then
  1619. begin
  1620. Message1(sym_e_id_no_member,pattern);
  1621. p1.destroy;
  1622. p1:=cerrornode.create;
  1623. { try to clean up }
  1624. pd:=generrordef;
  1625. consume(_ID);
  1626. end
  1627. else
  1628. begin
  1629. consume(_ID);
  1630. do_member_read(getaddr,sym,p1,pd,again);
  1631. end;
  1632. end;
  1633. pointerdef:
  1634. begin
  1635. Message(cg_e_invalid_qualifier);
  1636. if ppointerdef(pd)^.pointertype.def^.deftype in [recorddef,objectdef,classrefdef] then
  1637. Message(parser_h_maybe_deref_caret_missing);
  1638. end;
  1639. else
  1640. begin
  1641. Message(cg_e_invalid_qualifier);
  1642. p1.destroy;
  1643. p1:=cerrornode.create;
  1644. consume(_ID);
  1645. end;
  1646. end;
  1647. end;
  1648. else
  1649. begin
  1650. { is this a procedure variable ? }
  1651. if assigned(pd) then
  1652. begin
  1653. if (pd^.deftype=procvardef) then
  1654. begin
  1655. if getprocvar and is_equal(pd,getprocvardef) then
  1656. again:=false
  1657. else
  1658. if (token=_LKLAMMER) or
  1659. ((pprocvardef(pd)^.para^.empty) and
  1660. (not((token in [_ASSIGNMENT,_UNEQUAL,_EQUAL]))) and
  1661. (not afterassignment) and
  1662. (not in_args)) then
  1663. begin
  1664. { do this in a strange way }
  1665. { it's not a clean solution }
  1666. p2:=p1;
  1667. p1:=gencallnode(nil,nil);
  1668. tcallnode(p1).right:=p2;
  1669. {$ifdef TEST_PROCSYMS}
  1670. p1.unit_specific:=unit_specific;
  1671. {$endif TEST_PROCSYMS}
  1672. tcallnode(p1).symtableprocentry:=pprocsym(sym);
  1673. if token=_LKLAMMER then
  1674. begin
  1675. consume(_LKLAMMER);
  1676. tcallnode(p1).left:=parse_paras(false,false);
  1677. consume(_RKLAMMER);
  1678. end;
  1679. pd:=pprocvardef(pd)^.rettype.def;
  1680. { proc():= is never possible }
  1681. if token=_ASSIGNMENT then
  1682. begin
  1683. Message(cg_e_illegal_expression);
  1684. p1:=cerrornode.create;
  1685. again:=false;
  1686. end;
  1687. p1.resulttype:=pd;
  1688. end
  1689. else
  1690. again:=false;
  1691. p1.resulttype:=pd;
  1692. end
  1693. else
  1694. again:=false;
  1695. end
  1696. else
  1697. again:=false;
  1698. end;
  1699. end;
  1700. check_tokenpos;
  1701. end; { while again }
  1702. end;
  1703. {---------------------------------------------
  1704. Factor (Main)
  1705. ---------------------------------------------}
  1706. begin
  1707. oldp1:=nil;
  1708. p1:=nil;
  1709. filepos:=akttokenpos;
  1710. if token=_ID then
  1711. begin
  1712. factor_read_id;
  1713. { handle post fix operators }
  1714. postfixoperators;
  1715. end
  1716. else
  1717. case token of
  1718. _NEW : begin
  1719. consume(_NEW);
  1720. consume(_LKLAMMER);
  1721. {allow_type:=true;}
  1722. p1:=factor(false);
  1723. {allow_type:=false;}
  1724. if p1.nodetype<>typen then
  1725. begin
  1726. Message(type_e_type_id_expected);
  1727. p1.destroy;
  1728. pd:=generrordef;
  1729. end
  1730. else
  1731. pd:=ttypenode(p1).typenodetype;
  1732. pd2:=pd;
  1733. if (pd^.deftype<>pointerdef) then
  1734. Message1(type_e_pointer_type_expected,pd^.typename)
  1735. else
  1736. if token=_RKLAMMER then
  1737. begin
  1738. if (ppointerdef(pd)^.pointertype.def^.deftype=objectdef) and
  1739. (oo_has_vmt in pobjectdef(ppointerdef(pd)^.pointertype.def)^.objectoptions) then
  1740. Message(parser_w_use_extended_syntax_for_objects);
  1741. p1:=cnewnode.create(nil);
  1742. p1.resulttype:=pd2;
  1743. consume(_RKLAMMER);
  1744. end
  1745. else
  1746. begin
  1747. p1.destroy;
  1748. p1:=chnewnode.create;
  1749. p1.resulttype:=ppointerdef(pd)^.pointertype.def;
  1750. consume(_COMMA);
  1751. afterassignment:=false;
  1752. { determines the current object defintion }
  1753. classh:=pobjectdef(ppointerdef(pd)^.pointertype.def);
  1754. if classh^.deftype<>objectdef then
  1755. Message(parser_e_pointer_to_class_expected)
  1756. else
  1757. begin
  1758. { check for an abstract class }
  1759. if (oo_has_abstract in classh^.objectoptions) then
  1760. Message(sym_e_no_instance_of_abstract_object);
  1761. { search the constructor also in the symbol tables of
  1762. the parents }
  1763. sym:=nil;
  1764. while assigned(classh) do
  1765. begin
  1766. sym:=psym(classh^.symtable^.search(pattern));
  1767. srsymtable:=classh^.symtable;
  1768. if assigned(sym) then
  1769. break;
  1770. classh:=classh^.childof;
  1771. end;
  1772. consume(_ID);
  1773. do_member_read(false,sym,p1,pd,again);
  1774. if (p1.nodetype<>calln) or
  1775. (assigned(tcallnode(p1).procdefinition) and
  1776. (tcallnode(p1).procdefinition^.proctypeoption<>potype_constructor)) then
  1777. Message(parser_e_expr_have_to_be_constructor_call);
  1778. end;
  1779. p1:=cnewnode.create(p1);
  1780. { set the resulttype }
  1781. p1.resulttype:=pd2;
  1782. consume(_RKLAMMER);
  1783. end;
  1784. postfixoperators;
  1785. end;
  1786. _SELF : begin
  1787. again:=true;
  1788. consume(_SELF);
  1789. if not assigned(procinfo^._class) then
  1790. begin
  1791. p1:=cerrornode.create;
  1792. pd:=generrordef;
  1793. again:=false;
  1794. Message(parser_e_self_not_in_method);
  1795. end
  1796. else
  1797. begin
  1798. if (po_classmethod in aktprocsym^.definition^.procoptions) then
  1799. begin
  1800. { self in class methods is a class reference type }
  1801. pd:=new(pclassrefdef,init(procinfo^._class));
  1802. p1:=genselfnode(pd);
  1803. p1.resulttype:=pd;
  1804. end
  1805. else
  1806. begin
  1807. p1:=genselfnode(procinfo^._class);
  1808. p1.resulttype:=procinfo^._class;
  1809. end;
  1810. pd:=p1.resulttype;
  1811. postfixoperators;
  1812. end;
  1813. end;
  1814. _INHERITED : begin
  1815. again:=true;
  1816. consume(_INHERITED);
  1817. if assigned(procinfo^._class) then
  1818. begin
  1819. { if inherited; only then we need the method with
  1820. the same name }
  1821. if token=_SEMICOLON then
  1822. begin
  1823. hs:=aktprocsym^.name;
  1824. auto_inherited:=true
  1825. end
  1826. else
  1827. begin
  1828. hs:=pattern;
  1829. consume(_ID);
  1830. auto_inherited:=false;
  1831. end;
  1832. classh:=procinfo^._class^.childof;
  1833. while assigned(classh) do
  1834. begin
  1835. srsymtable:=pobjectdef(classh)^.symtable;
  1836. sym:=psym(srsymtable^.search(hs));
  1837. if assigned(sym) then
  1838. begin
  1839. { only for procsyms we need to set the type (PFV) }
  1840. case sym^.typ of
  1841. procsym :
  1842. begin
  1843. p1:=ctypenode.create(nil,nil);
  1844. p1.resulttype:=classh;
  1845. pd:=p1.resulttype;
  1846. end;
  1847. varsym :
  1848. begin
  1849. p1:=nil;
  1850. pd:=pvarsym(sym)^.vartype.def;
  1851. end;
  1852. propertysym :
  1853. begin
  1854. p1:=nil;
  1855. pd:=ppropertysym(sym)^.proptype.def;
  1856. end;
  1857. else
  1858. internalerror(83251763);
  1859. end;
  1860. do_member_read(false,sym,p1,pd,again);
  1861. break;
  1862. end;
  1863. classh:=classh^.childof;
  1864. end;
  1865. if classh=nil then
  1866. begin
  1867. Message1(sym_e_id_no_member,hs);
  1868. again:=false;
  1869. pd:=generrordef;
  1870. p1:=cerrornode.create;
  1871. end;
  1872. { turn auto inheriting off }
  1873. auto_inherited:=false;
  1874. end
  1875. else
  1876. begin
  1877. Message(parser_e_generic_methods_only_in_methods);
  1878. again:=false;
  1879. pd:=generrordef;
  1880. p1:=cerrornode.create;
  1881. end;
  1882. postfixoperators;
  1883. end;
  1884. _INTCONST : begin
  1885. { try cardinal first }
  1886. val(pattern,card,code);
  1887. if code<>0 then
  1888. begin
  1889. { then longint }
  1890. valint(pattern,l,code);
  1891. if code <> 0 then
  1892. begin
  1893. { then int64 }
  1894. val(pattern,ic,code);
  1895. if code<>0 then
  1896. begin
  1897. {finally float }
  1898. val(pattern,d,code);
  1899. if code<>0 then
  1900. begin
  1901. Message(cg_e_invalid_integer);
  1902. consume(_INTCONST);
  1903. l:=1;
  1904. p1:=genordinalconstnode(l,s32bitdef);
  1905. end
  1906. else
  1907. begin
  1908. consume(_INTCONST);
  1909. p1:=genrealconstnode(d,bestrealdef^);
  1910. end;
  1911. end
  1912. else
  1913. begin
  1914. consume(_INTCONST);
  1915. p1:=genordinalconstnode(ic,cs64bitdef);
  1916. end
  1917. end
  1918. else
  1919. begin
  1920. consume(_INTCONST);
  1921. p1:=genordinalconstnode(l,s32bitdef)
  1922. end
  1923. end
  1924. else
  1925. begin
  1926. consume(_INTCONST);
  1927. { check whether the value isn't in the longint range as well }
  1928. { (longint is easier to perform calculations with) (JM) }
  1929. if card <= $7fffffff then
  1930. { no sign extension necessary, so not longint typecast (JM) }
  1931. p1:=genordinalconstnode(card,s32bitdef)
  1932. else
  1933. p1:=genordinalconstnode(card,u32bitdef)
  1934. end;
  1935. end;
  1936. _REALNUMBER : begin
  1937. val(pattern,d,code);
  1938. if code<>0 then
  1939. begin
  1940. Message(parser_e_error_in_real);
  1941. d:=1.0;
  1942. end;
  1943. consume(_REALNUMBER);
  1944. p1:=genrealconstnode(d,bestrealdef^);
  1945. end;
  1946. _STRING : begin
  1947. pd:=string_dec;
  1948. { STRING can be also a type cast }
  1949. if token=_LKLAMMER then
  1950. begin
  1951. consume(_LKLAMMER);
  1952. p1:=comp_expr(true);
  1953. consume(_RKLAMMER);
  1954. p1:=gentypeconvnode(p1,pd);
  1955. include(p1.flags,nf_explizit);
  1956. { handle postfix operators here e.g. string(a)[10] }
  1957. again:=true;
  1958. postfixoperators;
  1959. end
  1960. else
  1961. p1:=gentypenode(pd,nil);
  1962. end;
  1963. _FILE : begin
  1964. pd:=cfiledef;
  1965. consume(_FILE);
  1966. { FILE can be also a type cast }
  1967. if token=_LKLAMMER then
  1968. begin
  1969. consume(_LKLAMMER);
  1970. p1:=comp_expr(true);
  1971. consume(_RKLAMMER);
  1972. p1:=gentypeconvnode(p1,pd);
  1973. include(p1.flags,nf_explizit);
  1974. { handle postfix operators here e.g. string(a)[10] }
  1975. again:=true;
  1976. postfixoperators;
  1977. end
  1978. else
  1979. p1:=gentypenode(pd,nil);
  1980. end;
  1981. _CSTRING : begin
  1982. p1:=genstringconstnode(pattern,st_default);
  1983. consume(_CSTRING);
  1984. end;
  1985. _CCHAR : begin
  1986. p1:=genordinalconstnode(ord(pattern[1]),cchardef);
  1987. consume(_CCHAR);
  1988. end;
  1989. _CWSTRING:
  1990. begin
  1991. p1:=genwstringconstnode(patternw);
  1992. consume(_CWSTRING);
  1993. end;
  1994. _CWCHAR:
  1995. begin
  1996. p1:=genordinalconstnode(ord(getcharwidestring(patternw,0)),cwidechardef);
  1997. consume(_CWCHAR);
  1998. end;
  1999. _KLAMMERAFFE : begin
  2000. consume(_KLAMMERAFFE);
  2001. got_addrn:=true;
  2002. { support both @<x> and @(<x>) }
  2003. if token=_LKLAMMER then
  2004. begin
  2005. consume(_LKLAMMER);
  2006. p1:=factor(true);
  2007. consume(_RKLAMMER);
  2008. if token in [_CARET,_POINT,_LECKKLAMMER] then
  2009. begin
  2010. { we need the resulttype }
  2011. { of the expression in pd }
  2012. do_firstpass(p1);
  2013. pd:=p1.resulttype;
  2014. again:=true;
  2015. postfixoperators;
  2016. end;
  2017. end
  2018. else
  2019. p1:=factor(true);
  2020. got_addrn:=false;
  2021. p1:=caddrnode.create(p1);
  2022. end;
  2023. _LKLAMMER : begin
  2024. consume(_LKLAMMER);
  2025. p1:=comp_expr(true);
  2026. consume(_RKLAMMER);
  2027. { it's not a good solution }
  2028. { but (a+b)^ makes some problems }
  2029. if token in [_CARET,_POINT,_LECKKLAMMER] then
  2030. begin
  2031. { we need the resulttype }
  2032. { of the expression in pd }
  2033. do_firstpass(p1);
  2034. pd:=p1.resulttype;
  2035. again:=true;
  2036. postfixoperators;
  2037. end;
  2038. end;
  2039. _LECKKLAMMER : begin
  2040. consume(_LECKKLAMMER);
  2041. p1:=factor_read_set;
  2042. consume(_RECKKLAMMER);
  2043. end;
  2044. _PLUS : begin
  2045. consume(_PLUS);
  2046. p1:=factor(false);
  2047. end;
  2048. _MINUS : begin
  2049. consume(_MINUS);
  2050. p1:=sub_expr(oppower,false);
  2051. p1:=cunaryminusnode.create(p1);
  2052. end;
  2053. _OP_NOT : begin
  2054. consume(_OP_NOT);
  2055. p1:=factor(false);
  2056. p1:=cnotnode.create(p1);
  2057. end;
  2058. _TRUE : begin
  2059. consume(_TRUE);
  2060. p1:=genordinalconstnode(1,booldef);
  2061. end;
  2062. _FALSE : begin
  2063. consume(_FALSE);
  2064. p1:=genordinalconstnode(0,booldef);
  2065. end;
  2066. _NIL : begin
  2067. consume(_NIL);
  2068. p1:=cnilnode.create;
  2069. end;
  2070. else
  2071. begin
  2072. p1:=cerrornode.create;
  2073. consume(token);
  2074. Message(cg_e_illegal_expression);
  2075. end;
  2076. end;
  2077. { generate error node if no node is created }
  2078. if not assigned(p1) then
  2079. p1:=cerrornode.create;
  2080. { tp7 procvar handling, but not if the next token
  2081. will be a := }
  2082. if (m_tp_procvar in aktmodeswitches) and
  2083. (token<>_ASSIGNMENT) then
  2084. check_tp_procvar(p1);
  2085. factor:=p1;
  2086. check_tokenpos;
  2087. end;
  2088. {$ifdef fpc}
  2089. {$maxfpuregisters default}
  2090. {$endif fpc}
  2091. {****************************************************************************
  2092. Sub_Expr
  2093. ****************************************************************************}
  2094. const
  2095. { Warning these stay be ordered !! }
  2096. operator_levels:array[Toperator_precedence] of set of Ttoken=
  2097. ([_LT,_LTE,_GT,_GTE,_EQUAL,_UNEQUAL,_OP_IN,_OP_IS],
  2098. [_PLUS,_MINUS,_OP_OR,_OP_XOR],
  2099. [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,
  2100. _OP_AS,_OP_AND,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR],
  2101. [_STARSTAR] );
  2102. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):tnode;
  2103. {Reads a subexpression while the operators are of the current precedence
  2104. level, or any higher level. Replaces the old term, simpl_expr and
  2105. simpl2_expr.}
  2106. var
  2107. p1,p2 : tnode;
  2108. oldt : Ttoken;
  2109. filepos : tfileposinfo;
  2110. begin
  2111. if pred_level=highest_precedence then
  2112. p1:=factor(false)
  2113. else
  2114. p1:=sub_expr(succ(pred_level),true);
  2115. repeat
  2116. if (token in operator_levels[pred_level]) and
  2117. ((token<>_EQUAL) or accept_equal) then
  2118. begin
  2119. oldt:=token;
  2120. filepos:=akttokenpos;
  2121. consume(token);
  2122. if pred_level=highest_precedence then
  2123. p2:=factor(false)
  2124. else
  2125. p2:=sub_expr(succ(pred_level),true);
  2126. case oldt of
  2127. _PLUS :
  2128. p1:=caddnode.create(addn,p1,p2);
  2129. _MINUS :
  2130. p1:=caddnode.create(subn,p1,p2);
  2131. _STAR :
  2132. p1:=caddnode.create(muln,p1,p2);
  2133. _SLASH :
  2134. p1:=caddnode.create(slashn,p1,p2);
  2135. _EQUAL :
  2136. p1:=caddnode.create(equaln,p1,p2);
  2137. _GT :
  2138. p1:=caddnode.create(gtn,p1,p2);
  2139. _LT :
  2140. p1:=caddnode.create(ltn,p1,p2);
  2141. _GTE :
  2142. p1:=caddnode.create(gten,p1,p2);
  2143. _LTE :
  2144. p1:=caddnode.create(lten,p1,p2);
  2145. _SYMDIF :
  2146. p1:=caddnode.create(symdifn,p1,p2);
  2147. _STARSTAR :
  2148. p1:=caddnode.create(starstarn,p1,p2);
  2149. _OP_AS :
  2150. p1:=casnode.create(p1,p2);
  2151. _OP_IN :
  2152. p1:=cinnode.create(p1,p2);
  2153. _OP_IS :
  2154. p1:=cisnode.create(p1,p2);
  2155. _OP_OR :
  2156. p1:=caddnode.create(orn,p1,p2);
  2157. _OP_AND :
  2158. p1:=caddnode.create(andn,p1,p2);
  2159. _OP_DIV :
  2160. p1:=cmoddivnode.create(divn,p1,p2);
  2161. _OP_NOT :
  2162. p1:=cnotnode.create(p1);
  2163. _OP_MOD :
  2164. p1:=cmoddivnode.create(modn,p1,p2);
  2165. _OP_SHL :
  2166. p1:=cshlshrnode.create(shln,p1,p2);
  2167. _OP_SHR :
  2168. p1:=cshlshrnode.create(shrn,p1,p2);
  2169. _OP_XOR :
  2170. p1:=caddnode.create(xorn,p1,p2);
  2171. _ASSIGNMENT :
  2172. p1:=cassignmentnode.create(p1,p2);
  2173. _CARET :
  2174. p1:=caddnode.create(caretn,p1,p2);
  2175. _UNEQUAL :
  2176. p1:=caddnode.create(unequaln,p1,p2);
  2177. end;
  2178. p1.set_tree_filepos(filepos);
  2179. end
  2180. else
  2181. break;
  2182. until false;
  2183. sub_expr:=p1;
  2184. end;
  2185. function comp_expr(accept_equal : boolean):tnode;
  2186. var
  2187. oldafterassignment : boolean;
  2188. p1 : tnode;
  2189. begin
  2190. oldafterassignment:=afterassignment;
  2191. afterassignment:=true;
  2192. p1:=sub_expr(opcompare,accept_equal);
  2193. afterassignment:=oldafterassignment;
  2194. comp_expr:=p1;
  2195. end;
  2196. function expr : tnode;
  2197. var
  2198. p1,p2 : tnode;
  2199. oldafterassignment : boolean;
  2200. oldp1 : tnode;
  2201. filepos : tfileposinfo;
  2202. begin
  2203. oldafterassignment:=afterassignment;
  2204. p1:=sub_expr(opcompare,true);
  2205. filepos:=akttokenpos;
  2206. if (m_tp_procvar in aktmodeswitches) and
  2207. (token<>_ASSIGNMENT) then
  2208. check_tp_procvar(p1);
  2209. if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  2210. afterassignment:=true;
  2211. oldp1:=p1;
  2212. case token of
  2213. _POINTPOINT :
  2214. begin
  2215. consume(_POINTPOINT);
  2216. p2:=sub_expr(opcompare,true);
  2217. p1:=crangenode.create(p1,p2);
  2218. end;
  2219. _ASSIGNMENT :
  2220. begin
  2221. consume(_ASSIGNMENT);
  2222. if (p1.resulttype<>nil) and (p1.resulttype^.deftype=procvardef) then
  2223. begin
  2224. getprocvar:=true;
  2225. getprocvardef:=pprocvardef(p1.resulttype);
  2226. end;
  2227. p2:=sub_expr(opcompare,true);
  2228. if getprocvar then
  2229. handle_procvar(getprocvardef,p2);
  2230. getprocvar:=false;
  2231. p1:=cassignmentnode.create(p1,p2);
  2232. end;
  2233. _PLUSASN :
  2234. begin
  2235. consume(_PLUSASN);
  2236. p2:=sub_expr(opcompare,true);
  2237. p1:=cassignmentnode.create(p1,caddnode.create(addn,p1.getcopy,p2));
  2238. end;
  2239. _MINUSASN :
  2240. begin
  2241. consume(_MINUSASN);
  2242. p2:=sub_expr(opcompare,true);
  2243. p1:=cassignmentnode.create(p1,caddnode.create(subn,p1.getcopy,p2));
  2244. end;
  2245. _STARASN :
  2246. begin
  2247. consume(_STARASN );
  2248. p2:=sub_expr(opcompare,true);
  2249. p1:=cassignmentnode.create(p1,caddnode.create(muln,p1.getcopy,p2));
  2250. end;
  2251. _SLASHASN :
  2252. begin
  2253. consume(_SLASHASN );
  2254. p2:=sub_expr(opcompare,true);
  2255. p1:=cassignmentnode.create(p1,caddnode.create(slashn,p1.getcopy,p2));
  2256. end;
  2257. end;
  2258. afterassignment:=oldafterassignment;
  2259. if p1<>oldp1 then
  2260. p1.set_tree_filepos(filepos);
  2261. expr:=p1;
  2262. end;
  2263. function get_intconst:TConstExprInt;
  2264. {Reads an expression, tries to evalute it and check if it is an integer
  2265. constant. Then the constant is returned.}
  2266. var
  2267. p:tnode;
  2268. begin
  2269. p:=comp_expr(true);
  2270. do_firstpass(p);
  2271. if not codegenerror then
  2272. begin
  2273. if (p.nodetype<>ordconstn) and
  2274. (p.resulttype^.deftype=orddef) and
  2275. not(Porddef(p.resulttype)^.typ in [uvoid,uchar,bool8bit,bool16bit,bool32bit]) then
  2276. Message(cg_e_illegal_expression)
  2277. else
  2278. get_intconst:=tordconstnode(p).value;
  2279. end;
  2280. p.free;
  2281. end;
  2282. function get_stringconst:string;
  2283. {Reads an expression, tries to evaluate it and checks if it is a string
  2284. constant. Then the constant is returned.}
  2285. var
  2286. p:tnode;
  2287. begin
  2288. get_stringconst:='';
  2289. p:=comp_expr(true);
  2290. do_firstpass(p);
  2291. if p.nodetype<>stringconstn then
  2292. begin
  2293. if (p.nodetype=ordconstn) and is_char(p.resulttype) then
  2294. get_stringconst:=char(tordconstnode(p).value)
  2295. else
  2296. Message(cg_e_illegal_expression);
  2297. end
  2298. else
  2299. get_stringconst:=strpas(tstringconstnode(p).value_str);
  2300. p.free;
  2301. end;
  2302. end.
  2303. {
  2304. $Log$
  2305. Revision 1.19 2000-12-07 17:19:42 jonas
  2306. * new constant handling: from now on, hex constants >$7fffffff are
  2307. parsed as unsigned constants (otherwise, $80000000 got sign extended
  2308. and became $ffffffff80000000), all constants in the longint range
  2309. become longints, all constants >$7fffffff and <=cardinal($ffffffff)
  2310. are cardinals and the rest are int64's.
  2311. * added lots of longint typecast to prevent range check errors in the
  2312. compiler and rtl
  2313. * type casts of symbolic ordinal constants are now preserved
  2314. * fixed bug where the original resulttype wasn't restored correctly
  2315. after doing a 64bit rangecheck
  2316. Revision 1.18 2000/11/29 00:30:36 florian
  2317. * unused units removed from uses clause
  2318. * some changes for widestrings
  2319. Revision 1.17 2000/11/09 17:46:55 florian
  2320. * System.TypeInfo fixed
  2321. + System.Finalize implemented
  2322. + some new keywords for interface support added
  2323. Revision 1.16 2000/11/06 20:30:55 peter
  2324. * more fixes to get make cycle working
  2325. Revision 1.15 2000/11/04 14:25:20 florian
  2326. + merged Attila's changes for interfaces, not tested yet
  2327. Revision 1.14 2000/10/31 22:02:49 peter
  2328. * symtable splitted, no real code changes
  2329. Revision 1.13 2000/10/26 23:40:54 peter
  2330. * fixed crash with call from type decl which is not allowed (merged)
  2331. Revision 1.12 2000/10/21 18:16:12 florian
  2332. * a lot of changes:
  2333. - basic dyn. array support
  2334. - basic C++ support
  2335. - some work for interfaces done
  2336. ....
  2337. Revision 1.11 2000/10/14 10:14:51 peter
  2338. * moehrendorf oct 2000 rewrite
  2339. Revision 1.10 2000/10/01 19:48:25 peter
  2340. * lot of compile updates for cg11
  2341. Revision 1.9 2000/09/24 21:19:50 peter
  2342. * delphi compile fixes
  2343. Revision 1.8 2000/09/24 15:06:22 peter
  2344. * use defines.inc
  2345. Revision 1.7 2000/08/27 16:11:51 peter
  2346. * moved some util functions from globals,cobjects to cutils
  2347. * splitted files into finput,fmodule
  2348. Revision 1.6 2000/08/20 15:12:49 peter
  2349. * auto derefence mode for array pointer (merged)
  2350. Revision 1.5 2000/08/16 18:33:53 peter
  2351. * splitted namedobjectitem.next into indexnext and listnext so it
  2352. can be used in both lists
  2353. * don't allow "word = word" type definitions (merged)
  2354. Revision 1.4 2000/08/16 13:06:06 florian
  2355. + support of 64 bit integer constants
  2356. Revision 1.3 2000/08/04 22:00:52 peter
  2357. * merges from fixes
  2358. Revision 1.2 2000/07/13 11:32:44 michael
  2359. + removed logs
  2360. }