pexpr.pas 96 KB

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