pexpr.pas 95 KB

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