pexpr.pas 78 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795
  1. {
  2. $Id$
  3. Copyright (c) 1998 by Florian Klaempfl
  4. Does parsing of expression for Free Pascal
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pexpr;
  19. interface
  20. uses symtable,tree;
  21. { reads a whole expression }
  22. function expr : ptree;
  23. { reads an expression without assignements and .. }
  24. function comp_expr(accept_equal : boolean):Ptree;
  25. { reads a single factor }
  26. function factor(getaddr : boolean) : ptree;
  27. { the ID token has to be consumed before calling this function }
  28. procedure do_member_read(const sym : psym;var p1 : ptree;
  29. var pd : pdef;var again : boolean);
  30. function get_intconst:longint;
  31. function get_stringconst:string;
  32. implementation
  33. uses
  34. cobjects,globals,scanner,aasm,pass_1,systems,
  35. hcodegen,types,verbose
  36. { parser specific stuff }
  37. ,pbase,pdecl
  38. { processor specific stuff }
  39. {$ifdef i386}
  40. ,i386
  41. {$endif}
  42. {$ifdef m68k}
  43. ,m68k
  44. {$endif}
  45. ;
  46. function parse_paras(_colon,in_prop_paras : boolean) : ptree;
  47. var
  48. p1,p2 : ptree;
  49. end_of_paras : ttoken;
  50. begin
  51. if in_prop_paras then
  52. end_of_paras:=RECKKLAMMER
  53. else
  54. end_of_paras:=RKLAMMER;
  55. if token=end_of_paras then
  56. begin
  57. parse_paras:=nil;
  58. exit;
  59. end;
  60. p2:=nil;
  61. inc(parsing_para_level);
  62. while true do
  63. begin
  64. p1:=comp_expr(true);
  65. p2:=gencallparanode(p1,p2);
  66. { it's for the str(l:5,s); }
  67. if _colon and (token=COLON) then
  68. begin
  69. consume(COLON);
  70. p1:=comp_expr(true);
  71. p2:=gencallparanode(p1,p2);
  72. p2^.is_colon_para:=true;
  73. if token=COLON then
  74. begin
  75. consume(COLON);
  76. p1:=comp_expr(true);
  77. p2:=gencallparanode(p1,p2);
  78. p2^.is_colon_para:=true;
  79. end
  80. end;
  81. if token=COMMA then
  82. consume(COMMA)
  83. else
  84. break;
  85. end;
  86. dec(parsing_para_level);
  87. parse_paras:=p2;
  88. end;
  89. function statement_syssym(l : longint;var pd : pdef) : ptree;
  90. { const regnames:array[R_EAX..R_EDI] of string[3]=
  91. ('EAX','ECX','EDX','EBX','','','ESI','EDI'); }
  92. var
  93. p1,p2 : ptree;
  94. paras : ptree;
  95. prev_in_args : boolean;
  96. Store_valid : boolean;
  97. begin
  98. prev_in_args:=in_args;
  99. Store_valid:=Must_be_valid;
  100. case l of
  101. in_ord_x:
  102. begin
  103. consume(LKLAMMER);
  104. in_args:=true;
  105. Must_be_valid:=true;
  106. p1:=comp_expr(true);
  107. consume(RKLAMMER);
  108. do_firstpass(p1);
  109. p1:=geninlinenode(in_ord_x,p1);
  110. do_firstpass(p1);
  111. statement_syssym := p1;
  112. pd:=p1^.resulttype;
  113. end;
  114. in_break:
  115. begin
  116. statement_syssym:=genzeronode(breakn);
  117. pd:=voiddef;
  118. end;
  119. in_continue:
  120. begin
  121. statement_syssym:=genzeronode(continuen);
  122. pd:=voiddef;
  123. end;
  124. in_typeof_x : begin
  125. consume(LKLAMMER);
  126. in_args:=true;
  127. p1:=comp_expr(true);
  128. consume(RKLAMMER);
  129. pd:=voidpointerdef;
  130. if p1^.treetype=typen then
  131. begin
  132. if (p1^.resulttype=nil) then
  133. begin
  134. Message(sym_e_type_mismatch);
  135. statement_syssym:=genzeronode(errorn);
  136. end
  137. else
  138. if p1^.resulttype^.deftype=objectdef then
  139. statement_syssym:=geninlinenode(in_typeof_x,p1)
  140. else
  141. begin
  142. Message(sym_e_type_mismatch);
  143. statement_syssym:=genzeronode(errorn);
  144. end;
  145. end
  146. else
  147. begin
  148. Must_be_valid:=false;
  149. do_firstpass(p1);
  150. if (p1^.resulttype=nil) then
  151. begin
  152. Message(sym_e_type_mismatch);
  153. statement_syssym:=genzeronode(errorn)
  154. end
  155. else
  156. if p1^.resulttype^.deftype=objectdef then
  157. statement_syssym:=geninlinenode(in_typeof_x,p1)
  158. else
  159. begin
  160. Message(sym_e_type_mismatch);
  161. statement_syssym:=genzeronode(errorn)
  162. end;
  163. end;
  164. end;
  165. in_sizeof_x : begin
  166. consume(LKLAMMER);
  167. in_args:=true;
  168. p1:=comp_expr(true);
  169. consume(RKLAMMER);
  170. pd:=s32bitdef;
  171. if p1^.treetype=typen then
  172. begin
  173. statement_syssym:=genordinalconstnode(
  174. p1^.resulttype^.size,pd);
  175. { p1 not needed !}
  176. disposetree(p1);
  177. end
  178. else
  179. begin
  180. Must_be_valid:=false;
  181. do_firstpass(p1);
  182. if p1^.resulttype^.deftype<>objectdef then
  183. begin
  184. statement_syssym:=genordinalconstnode(
  185. p1^.resulttype^.size,pd);
  186. { p1 not needed !}
  187. disposetree(p1);
  188. end
  189. else
  190. begin
  191. statement_syssym:=geninlinenode(in_sizeof_x,p1);
  192. end;
  193. end;
  194. end;
  195. in_assigned_x : begin
  196. consume(LKLAMMER);
  197. in_args:=true;
  198. p1:=comp_expr(true);
  199. Must_be_valid:=true;
  200. do_firstpass(p1);
  201. case p1^.resulttype^.deftype of
  202. pointerdef,procvardef,
  203. classrefdef:
  204. ;
  205. objectdef:
  206. if not(pobjectdef(p1^.resulttype)^.isclass) then
  207. Message(parser_e_illegal_parameter_list);
  208. else Message(parser_e_illegal_parameter_list);
  209. end;
  210. p2:=gencallparanode(p1,nil);
  211. p2:=geninlinenode(in_assigned_x,p2);
  212. consume(RKLAMMER);
  213. pd:=booldef;
  214. statement_syssym:=p2;
  215. end;
  216. in_ofs_x : begin
  217. consume(LKLAMMER);
  218. in_args:=true;
  219. p1:=comp_expr(true);
  220. p1:=gensinglenode(addrn,p1);
  221. Must_be_valid:=false;
  222. do_firstpass(p1);
  223. { Ofs() returns a longint, not a pointer }
  224. p1^.resulttype:=u32bitdef;
  225. pd:=p1^.resulttype;
  226. consume(RKLAMMER);
  227. statement_syssym:=p1;
  228. end;
  229. in_seg_x : begin
  230. consume(LKLAMMER);
  231. in_args:=true;
  232. p1:=comp_expr(true);
  233. do_firstpass(p1);
  234. if p1^.location.loc<>LOC_REFERENCE then
  235. Message(cg_e_illegal_expression);
  236. p1:=genordinalconstnode(0,s32bitdef);
  237. Must_be_valid:=false;
  238. pd:=s32bitdef;
  239. consume(RKLAMMER);
  240. statement_syssym:=p1;
  241. end;
  242. in_high_x,
  243. in_low_x : begin
  244. consume(LKLAMMER);
  245. in_args:=true;
  246. p1:=comp_expr(true);
  247. do_firstpass(p1);
  248. Must_be_valid:=false;
  249. p2:=geninlinenode(l,p1);
  250. consume(RKLAMMER);
  251. pd:=s32bitdef;
  252. statement_syssym:=p2;
  253. end;
  254. in_succ_x,
  255. in_pred_x : begin
  256. consume(LKLAMMER);
  257. in_args:=true;
  258. p1:=comp_expr(true);
  259. do_firstpass(p1);
  260. Must_be_valid:=false;
  261. p2:=geninlinenode(l,p1);
  262. consume(RKLAMMER);
  263. pd:=p1^.resulttype;
  264. statement_syssym:=p2;
  265. end;
  266. in_inc_x,
  267. in_dec_x : begin
  268. consume(LKLAMMER);
  269. in_args:=true;
  270. p1:=comp_expr(true);
  271. p2:=gencallparanode(p1,nil);
  272. Must_be_valid:=false;
  273. if token=COMMA then
  274. begin
  275. consume(COMMA);
  276. p1:=comp_expr(true);
  277. p2:=gencallparanode(p1,p2);
  278. end;
  279. statement_syssym:=geninlinenode(l,p2);
  280. consume(RKLAMMER);
  281. pd:=voiddef;
  282. end;
  283. in_concat_x : begin
  284. consume(LKLAMMER);
  285. in_args:=true;
  286. p2:=nil;
  287. while true do
  288. begin
  289. p1:=comp_expr(true);
  290. Must_be_valid:=true;
  291. do_firstpass(p1);
  292. if not((p1^.resulttype^.deftype=stringdef) or
  293. ((p1^.resulttype^.deftype=orddef) and
  294. (porddef(p1^.resulttype)^.typ=uchar)
  295. )
  296. ) then Message(parser_e_illegal_parameter_list);
  297. if p2<>nil then
  298. p2:=gennode(addn,p2,p1)
  299. else p2:=p1;
  300. if token=COMMA then
  301. consume(COMMA)
  302. else break;
  303. end;
  304. consume(RKLAMMER);
  305. pd:=cstringdef;
  306. statement_syssym:=p2;
  307. end;
  308. in_read_x,
  309. in_readln_x : begin
  310. if token=LKLAMMER then
  311. begin
  312. consume(LKLAMMER);
  313. in_args:=true;
  314. Must_be_valid:=false;
  315. paras:=parse_paras(false,false);
  316. consume(RKLAMMER);
  317. end
  318. else
  319. paras:=nil;
  320. pd:=voiddef;
  321. p1:=geninlinenode(l,paras);
  322. do_firstpass(p1);
  323. statement_syssym := p1;
  324. end;
  325. in_write_x,
  326. in_writeln_x : begin
  327. if token=LKLAMMER then
  328. begin
  329. consume(LKLAMMER);
  330. in_args:=true;
  331. Must_be_valid:=true;
  332. paras:=parse_paras(true,false);
  333. consume(RKLAMMER);
  334. end
  335. else
  336. paras:=nil;
  337. pd:=voiddef;
  338. p1 := geninlinenode(l,paras);
  339. do_firstpass(p1);
  340. statement_syssym := p1;
  341. end;
  342. in_str_x_string : begin
  343. consume(LKLAMMER);
  344. in_args:=true;
  345. paras:=parse_paras(true,false);
  346. consume(RKLAMMER);
  347. p1 := geninlinenode(l,paras);
  348. do_firstpass(p1);
  349. statement_syssym := p1;
  350. pd:=voiddef;
  351. end;
  352. in_include_x_y,
  353. in_exclude_x_y:
  354. begin
  355. consume(LKLAMMER);
  356. in_args:=true;
  357. p1:=comp_expr(true);
  358. Must_be_valid:=false;
  359. consume(COMMA);
  360. p2:=comp_expr(true);
  361. { just a bit lisp feeling }
  362. statement_syssym:=geninlinenode(l,
  363. gencallparanode(p1,gencallparanode(p2,nil)));
  364. consume(RKLAMMER);
  365. pd:=voiddef;
  366. end;
  367. {in_val_x : begin
  368. consume(LKLAMMER);
  369. paras:=parse_paras(false);
  370. consume(RKLAMMER);
  371. p1 := geninlinenode(l,paras);
  372. do_firstpass(p1);
  373. statement_syssym := p1;
  374. pd:=voiddef;
  375. end; }
  376. else internalerror(15);
  377. end;
  378. in_args:=prev_in_args;
  379. Must_be_valid:=Store_valid;
  380. end;
  381. { reads the parameter for a subroutine call }
  382. procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
  383. var
  384. prev_in_args : boolean;
  385. prevafterassn : boolean;
  386. begin
  387. prev_in_args:=in_args;
  388. prevafterassn:=afterassignment;
  389. afterassignment:=false;
  390. { want we only determine the address of }
  391. { a subroutine }
  392. if not(getaddr) then
  393. begin
  394. if token=LKLAMMER then
  395. begin
  396. consume(LKLAMMER);
  397. in_args:=true;
  398. p1^.left:=parse_paras(false,false);
  399. consume(RKLAMMER);
  400. end
  401. else p1^.left:=nil;
  402. { do firstpass because we need the }
  403. { result type }
  404. do_firstpass(p1);
  405. end
  406. else
  407. begin
  408. { address operator @: }
  409. p1^.left:=nil;
  410. { forget pd }
  411. pd:=nil;
  412. { no postfix operators }
  413. again:=false;
  414. end;
  415. pd:=p1^.resulttype;
  416. in_args:=prev_in_args;
  417. afterassignment:=prevafterassn;
  418. end;
  419. { the following procedure handles the access to a property symbol }
  420. procedure handle_propertysym(sym : psym;var p1 : ptree;
  421. var pd : pdef);
  422. var
  423. paras : ptree;
  424. p2 : ptree;
  425. begin
  426. paras:=nil;
  427. { property parameters? }
  428. if token=LECKKLAMMER then
  429. begin
  430. consume(LECKKLAMMER);
  431. paras:=parse_paras(false,true);
  432. consume(RECKKLAMMER);
  433. end;
  434. { indexed property }
  435. if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
  436. begin
  437. p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
  438. paras:=gencallparanode(p2,paras);
  439. end;
  440. if not(afterassignment) and not(in_args) then
  441. begin
  442. { write property: }
  443. { no result }
  444. pd:=voiddef;
  445. if assigned(ppropertysym(sym)^.writeaccesssym) then
  446. begin
  447. if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
  448. begin
  449. { generate the method call }
  450. p1:=genmethodcallnode(pprocsym(
  451. ppropertysym(sym)^.writeaccesssym),
  452. ppropertysym(sym)^.writeaccesssym^.owner,p1);
  453. { we know the procedure to call, so
  454. force the usage of that procedure }
  455. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccessdef);
  456. p1^.left:=paras;
  457. consume(ASSIGNMENT);
  458. { read the expression }
  459. p2:=comp_expr(true);
  460. p1^.left:=gencallparanode(p2,p1^.left);
  461. end
  462. else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
  463. begin
  464. if assigned(paras) then
  465. message(parser_e_no_paras_allowed);
  466. { subscribed access? }
  467. if p1=nil then
  468. begin
  469. p1:=genloadnode(pvarsym(ppropertysym(sym)^.readaccesssym),
  470. ppropertysym(sym)^.readaccesssym^.owner);
  471. end
  472. else
  473. p1:=gensubscriptnode(pvarsym(
  474. ppropertysym(sym)^.readaccesssym),p1);
  475. consume(ASSIGNMENT);
  476. { read the expression }
  477. p2:=comp_expr(true);
  478. p1:=gennode(assignn,p1,p2);
  479. end
  480. else
  481. begin
  482. p1:=genzeronode(errorn);
  483. Message(parser_e_no_procedure_to_access_property);
  484. end;
  485. end
  486. else
  487. begin
  488. p1:=genzeronode(errorn);
  489. Message(parser_e_no_procedure_to_access_property);
  490. end;
  491. end
  492. else
  493. begin
  494. { read property: }
  495. pd:=ppropertysym(sym)^.proptype;
  496. if assigned(ppropertysym(sym)^.readaccesssym) then
  497. begin
  498. if ppropertysym(sym)^.readaccesssym^.typ=varsym then
  499. begin
  500. if assigned(paras) then
  501. message(parser_e_no_paras_allowed);
  502. { subscribed access? }
  503. if p1=nil then
  504. begin
  505. p1:=genloadnode(pvarsym(ppropertysym(sym)^.readaccesssym),
  506. ppropertysym(sym)^.readaccesssym^.owner);
  507. end
  508. else
  509. p1:=gensubscriptnode(pvarsym(
  510. ppropertysym(sym)^.readaccesssym),p1);
  511. end
  512. else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
  513. begin
  514. { generate the method call }
  515. p1:=genmethodcallnode(pprocsym(
  516. ppropertysym(sym)^.readaccesssym),
  517. ppropertysym(sym)^.readaccesssym^.owner,p1);
  518. { we know the procedure to call, so
  519. force the usage of that procedure }
  520. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.readaccessdef);
  521. { insert paras }
  522. p1^.left:=paras;
  523. { if we should be delphi compatible }
  524. { then force type conversion }
  525. { }
  526. { isn't neccessary, the result types }
  527. { have to match excatly }
  528. {if cs_delphi2_compatible in aktswitches then
  529. p1:=gentypeconvnode(p1,pd);
  530. }
  531. end
  532. else
  533. begin
  534. p1:=genzeronode(errorn);
  535. Message(sym_e_type_mismatch);
  536. end;
  537. end
  538. else
  539. begin
  540. { error, no function to read property }
  541. p1:=genzeronode(errorn);
  542. Message(parser_e_no_procedure_to_access_property);
  543. end;
  544. end;
  545. end;
  546. { the ID token has to be consumed before calling this function }
  547. procedure do_member_read(const sym : psym;var p1 : ptree;
  548. var pd : pdef;var again : boolean);
  549. var
  550. static_name : string;
  551. isclassref : boolean;
  552. begin
  553. if sym=nil then
  554. begin
  555. Message(sym_e_id_no_member);
  556. disposetree(p1);
  557. p1:=genzeronode(errorn);
  558. { try to clean up }
  559. pd:=generrordef;
  560. again:=false;
  561. end
  562. else
  563. begin
  564. isclassref:=pd^.deftype=classrefdef;
  565. { check protected and private members }
  566. if ((sym^.properties and sp_private)<>0) and
  567. (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then
  568. Message(parser_e_cant_access_private_member);
  569. if ((sym^.properties and sp_protected)<>0) and
  570. (pobjectdef(pd)^.owner^.symtabletype=unitsymtable) then
  571. Message(parser_e_cant_access_protected_member);
  572. { we assume, that only procsyms and varsyms are in an object }
  573. { symbol table, for classes, properties are allowed }
  574. case sym^.typ of
  575. procsym:
  576. begin
  577. p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
  578. do_proc_call(false,again,p1,pd);
  579. { now we know the real method e.g. we can check for }
  580. { a class method }
  581. if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
  582. Message(parser_e_only_class_methods_via_class_ref);
  583. end;
  584. varsym:
  585. begin
  586. if isclassref then
  587. Message(parser_e_only_class_methods_via_class_ref);
  588. if (sym^.properties and sp_static)<>0 then
  589. begin
  590. static_name:=lowercase(srsymtable^.name^)+'_'+sym^.name;
  591. getsym(static_name,true);
  592. disposetree(p1);
  593. p1:=genloadnode(pvarsym(srsym),srsymtable);
  594. end
  595. else
  596. p1:=gensubscriptnode(pvarsym(sym),p1);
  597. pd:=pvarsym(sym)^.definition;
  598. end;
  599. propertysym:
  600. begin
  601. if isclassref then
  602. Message(parser_e_only_class_methods_via_class_ref);
  603. handle_propertysym(sym,p1,pd);
  604. end;
  605. else internalerror(16);
  606. end;
  607. end;
  608. end;
  609. function factor(getaddr : boolean) : ptree;
  610. var
  611. l : longint;
  612. p1,p2,p3 : ptree;
  613. code : word;
  614. pd,pd2 : pdef;
  615. unit_specific, again : boolean;
  616. static_name : string;
  617. sym : pvarsym;
  618. classh : pobjectdef;
  619. d : bestreal;
  620. constset : pconstset;
  621. propsym : ppropertysym;
  622. {$ifdef UseTokenInfo}
  623. oldp1 : ptree;
  624. filepos : tfileposinfo;
  625. {$endif UseTokenInfo}
  626. {$ifdef UseTokenInfo}
  627. procedure check_tokenpos;
  628. begin
  629. if (p1<>oldp1) then
  630. begin
  631. if assigned(p1) then
  632. set_tree_filepos(p1,filepos);
  633. oldp1:=p1;
  634. filepos:=tokenpos;
  635. end;
  636. end;
  637. {$endif UseTokenInfo}
  638. { p1 and p2 must contain valid values }
  639. procedure postfixoperators;
  640. begin
  641. {$ifdef UseTokenInfo}
  642. check_tokenpos;
  643. {$endif UseTokenInfo}
  644. while again do
  645. begin
  646. case token of
  647. CARET:
  648. begin
  649. consume(CARET);
  650. if pd^.deftype<>pointerdef then
  651. begin
  652. { ^ as binary operator is a problem!!!! (FK) }
  653. again:=false;
  654. Message(cg_e_invalid_qualifier);
  655. disposetree(p1);
  656. p1:=genzeronode(errorn);
  657. end
  658. else
  659. begin
  660. p1:=gensinglenode(derefn,p1);
  661. pd:=ppointerdef(pd)^.definition;
  662. end;
  663. end;
  664. LECKKLAMMER:
  665. begin
  666. if (pd^.deftype=objectdef) and
  667. pobjectdef(pd)^.isclass then
  668. begin
  669. { default property }
  670. propsym:=search_default_property(pobjectdef(pd));
  671. if not(assigned(propsym)) then
  672. begin
  673. disposetree(p1);
  674. p1:=genzeronode(errorn);
  675. again:=false;
  676. message(parser_e_no_default_property_available);
  677. end
  678. else
  679. begin
  680. p1:=nil;
  681. handle_propertysym(propsym,p1,pd);
  682. end;
  683. end
  684. else
  685. begin
  686. consume(LECKKLAMMER);
  687. repeat
  688. if (pd^.deftype<>arraydef) and
  689. (pd^.deftype<>stringdef) and
  690. (pd^.deftype<>pointerdef) then
  691. begin
  692. Message(cg_e_invalid_qualifier);
  693. disposetree(p1);
  694. p1:=genzeronode(errorn);
  695. again:=false;
  696. end
  697. else if (pd^.deftype=pointerdef) then
  698. begin
  699. p2:=comp_expr(true);
  700. p1:=gennode(vecn,p1,p2);
  701. pd:=ppointerdef(pd)^.definition;
  702. end
  703. else
  704. begin
  705. p2:=comp_expr(true);
  706. { support SEG:OFS for go32v2 Mem[] }
  707. if (target_info.target=target_GO32V2) and
  708. (p1^.treetype=loadn) and
  709. assigned(p1^.symtableentry) and
  710. assigned(p1^.symtableentry^.owner^.name) and
  711. (p1^.symtableentry^.owner^.name^='SYSTEM') and
  712. ((p1^.symtableentry^.name='MEM') or
  713. (p1^.symtableentry^.name='MEMW') or
  714. (p1^.symtableentry^.name='MEML')) then
  715. begin
  716. if (token=COLON) then
  717. begin
  718. consume(COLON);
  719. p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
  720. p2:=comp_expr(true);
  721. p2:=gennode(addn,p2,p3);
  722. p1:=gennode(vecn,p1,p2);
  723. p1^.memseg:=true;
  724. p1^.memindex:=true;
  725. end
  726. else
  727. begin
  728. p1:=gennode(vecn,p1,p2);
  729. p1^.memindex:=true;
  730. end;
  731. end
  732. { else
  733. if (target_info.target=target_GO32V2) and
  734. assigned(p1^.symtableentry) and
  735. assigned(p1^.symtableentry^.owner^.name) and
  736. (p1^.symtableentry^.owner^.name^='SYSTEM') and
  737. ((p1^.symtableentry^.name='PORT') or
  738. (p1^.symtableentry^.name='PORTW') or
  739. (p1^.symtableentry^.name='PORTL')) then
  740. begin
  741. p1:=gennode(vecn,p1,p2);
  742. p1^.portindex:=true;
  743. p
  744. end;
  745. end }
  746. else
  747. p1:=gennode(vecn,p1,p2);
  748. if pd^.deftype=stringdef then
  749. pd:=cchardef
  750. else
  751. pd:=parraydef(pd)^.definition;
  752. end;
  753. if token=COMMA then consume(COMMA)
  754. else break;
  755. until false;
  756. consume(RECKKLAMMER);
  757. end;
  758. end;
  759. POINT:
  760. begin
  761. consume(POINT);
  762. case pd^.deftype of
  763. recorddef:
  764. begin
  765. sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
  766. consume(ID);
  767. if sym=nil then
  768. begin
  769. Message(sym_e_illegal_field);
  770. disposetree(p1);
  771. p1:=genzeronode(errorn);
  772. end
  773. else
  774. begin
  775. p1:=gensubscriptnode(sym,p1);
  776. pd:=sym^.definition;
  777. end;
  778. end;
  779. classrefdef:
  780. begin
  781. classh:=pobjectdef(pclassrefdef(pd)^.definition);
  782. sym:=nil;
  783. while assigned(classh) do
  784. begin
  785. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  786. srsymtable:=classh^.publicsyms;
  787. if assigned(sym) then
  788. break;
  789. classh:=classh^.childof;
  790. end;
  791. consume(ID);
  792. do_member_read(sym,p1,pd,again);
  793. end;
  794. objectdef:
  795. begin
  796. classh:=pobjectdef(pd);
  797. sym:=nil;
  798. while assigned(classh) do
  799. begin
  800. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  801. srsymtable:=classh^.publicsyms;
  802. if assigned(sym) then
  803. break;
  804. classh:=classh^.childof;
  805. end;
  806. consume(ID);
  807. do_member_read(sym,p1,pd,again);
  808. end;
  809. pointerdef:
  810. begin
  811. if ppointerdef(pd)^.definition^.deftype
  812. in [recorddef,objectdef,classrefdef] then
  813. begin
  814. Message(cg_e_invalid_qualifier);
  815. { exterror:=strpnew(' may be pointer deref ^ is missing');
  816. error(invalid_qualifizier); }
  817. Comment(V_hint,' may be pointer deref ^ is missing');
  818. end
  819. else
  820. Message(cg_e_invalid_qualifier);
  821. end
  822. else
  823. begin
  824. Message(cg_e_invalid_qualifier);
  825. disposetree(p1);
  826. p1:=genzeronode(errorn);
  827. end;
  828. end;
  829. end;
  830. else
  831. begin
  832. { is this a procedure variable ? }
  833. if assigned(pd) then
  834. begin
  835. if (pd^.deftype=procvardef) then
  836. begin
  837. if getprocvar then
  838. again:=false
  839. else
  840. if (token=LKLAMMER) or
  841. ((pprocvardef(pd)^.para1=nil) and
  842. (token<>ASSIGNMENT) and (not in_args)) then
  843. begin
  844. { do this in a strange way }
  845. { it's not a clean solution }
  846. p2:=p1;
  847. p1:=gencallnode(nil,
  848. nil);
  849. p1^.right:=p2;
  850. p1^.unit_specific:=unit_specific;
  851. if token=LKLAMMER then
  852. begin
  853. consume(LKLAMMER);
  854. p1^.left:=parse_paras(false,false);
  855. consume(RKLAMMER);
  856. end;
  857. pd:=pprocvardef(pd)^.retdef;
  858. p1^.resulttype:=pd;
  859. end
  860. else again:=false;
  861. p1^.resulttype:=pd;
  862. end
  863. else again:=false;
  864. end
  865. else again:=false;
  866. end;
  867. end;
  868. {$ifdef UseTokenInfo}
  869. check_tokenpos;
  870. {$endif UseTokenInfo}
  871. end;
  872. end;
  873. procedure do_set(p : pconstset;pos : longint);
  874. var
  875. l : longint;
  876. begin
  877. if (pos>255) or
  878. (pos<0) then
  879. Message(parser_e_illegal_set_expr);
  880. l:=pos div 8;
  881. { do we allow the same twice }
  882. if (p^[l] and (1 shl (pos mod 8)))<>0 then
  883. Message(parser_e_illegal_set_expr);
  884. p^[l]:=p^[l] or (1 shl (pos mod 8));
  885. end;
  886. var
  887. possible_error : boolean;
  888. begin
  889. {$ifdef UseTokenInfo}
  890. oldp1:=nil;
  891. filepos:=tokenpos;
  892. {$endif UseTokenInfo}
  893. case token of
  894. ID:
  895. begin
  896. { allow post fix operators }
  897. again:=true;
  898. if (cs_delphi2_compatible in aktswitches) and
  899. (pattern='RESULT') and
  900. assigned(aktprocsym) and
  901. (procinfo.retdef<>pdef(voiddef)) then
  902. begin
  903. consume(ID);
  904. p1:=genzeronode(funcretn);
  905. pd:=procinfo.retdef;
  906. {$ifdef TEST_FUNCRET}
  907. p1^.funcretprocinfo:=pointer(@procinfo);
  908. p1^.retdef:=pd;
  909. {$endif TEST_FUNCRET}
  910. end
  911. else
  912. begin
  913. getsym(pattern,true);
  914. consume(ID);
  915. { is this an access to a function result ? }
  916. if assigned(aktprocsym) and
  917. ((srsym^.name=aktprocsym^.name) or
  918. ((pvarsym(srsym)=opsym) and
  919. ((procinfo.flags and pi_operator)<>0))) and
  920. (procinfo.retdef<>pdef(voiddef)) and
  921. (token<>LKLAMMER) and
  922. (not ((cs_tp_compatible in aktswitches) and
  923. (afterassignment or in_args))) then
  924. begin
  925. p1:=genzeronode(funcretn);
  926. pd:=procinfo.retdef;
  927. {$ifdef TEST_FUNCRET}
  928. p1^.funcretprocinfo:=pointer(@procinfo);
  929. p1^.retdef:=pd;
  930. {$endif TEST_FUNCRET}
  931. end
  932. else
  933. { else it's a normal symbol }
  934. begin
  935. if srsym^.typ=unitsym then
  936. begin
  937. consume(POINT);
  938. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  939. unit_specific:=true;
  940. consume(ID);
  941. end
  942. else
  943. unit_specific:=false;
  944. { check semantics of private }
  945. if (srsym^.typ in [propertysym,procsym,varsym]) and
  946. (srsymtable^.symtabletype=objectsymtable) then
  947. begin
  948. if ((srsym^.properties and sp_private)<>0) and
  949. (pobjectdef(srsym^.owner^.defowner)^.
  950. owner^.symtabletype=unitsymtable) then
  951. Message(parser_e_cant_access_private_member);
  952. end;
  953. case srsym^.typ of
  954. absolutesym:
  955. begin
  956. p1:=genloadnode(pvarsym(srsym),srsymtable);
  957. pd:=pabsolutesym(srsym)^.definition;
  958. end;
  959. varsym:
  960. begin
  961. { are we in a class method ? }
  962. if (srsymtable^.symtabletype=objectsymtable) and
  963. assigned(aktprocsym) and
  964. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  965. Message(parser_e_only_class_methods);
  966. if (srsym^.properties and sp_static)<>0 then
  967. begin
  968. static_name:=lowercase(srsymtable^.name^)+'_'+srsym^.name;
  969. getsym(static_name,true);
  970. end;
  971. p1:=genloadnode(pvarsym(srsym),srsymtable);
  972. if pvarsym(srsym)^.is_valid=0 then
  973. begin
  974. p1^.is_first := true;
  975. { set special between first loaded
  976. until checked in firstpass }
  977. pvarsym(srsym)^.is_valid:=2;
  978. end;
  979. pd:=pvarsym(srsym)^.definition;
  980. end;
  981. typedconstsym:
  982. begin
  983. p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
  984. pd:=ptypedconstsym(srsym)^.definition;
  985. end;
  986. syssym:
  987. p1:=statement_syssym(psyssym(srsym)^.number,pd);
  988. typesym:
  989. begin
  990. pd:=ptypesym(srsym)^.definition;
  991. { if we read a type declaration }
  992. { we have to return the type and }
  993. { nothing else }
  994. if block_type=bt_type then
  995. begin
  996. p1:=genzeronode(typen);
  997. p1^.resulttype:=pd;
  998. pd:=voiddef;
  999. end
  1000. else
  1001. begin
  1002. if token=LKLAMMER then
  1003. begin
  1004. consume(LKLAMMER);
  1005. p1:=comp_expr(true);
  1006. consume(RKLAMMER);
  1007. p1:=gentypeconvnode(p1,pd);
  1008. p1^.explizit:=true;
  1009. end
  1010. else if (token=POINT) and
  1011. (pd^.deftype=objectdef) and
  1012. ((pobjectdef(pd)^.options and oois_class)=0) then
  1013. begin
  1014. consume(POINT);
  1015. if assigned(procinfo._class) then
  1016. begin
  1017. if procinfo._class^.isrelated(pobjectdef(pd)) then
  1018. begin
  1019. p1:=genzeronode(typen);
  1020. p1^.resulttype:=pd;
  1021. srsymtable:=pobjectdef(pd)^.publicsyms;
  1022. sym:=pvarsym(srsymtable^.search(pattern));
  1023. consume(ID);
  1024. do_member_read(sym,p1,pd,again);
  1025. end
  1026. else
  1027. begin
  1028. Message(parser_e_no_super_class);
  1029. pd:=generrordef;
  1030. again:=false;
  1031. end;
  1032. end
  1033. else
  1034. begin
  1035. { allows @TObject.Load }
  1036. { also allows static methods and variables }
  1037. p1:=genzeronode(typen);
  1038. p1^.resulttype:=pd;
  1039. srsymtable:=pobjectdef(pd)^.publicsyms;
  1040. sym:=pvarsym(srsymtable^.search(pattern));
  1041. if not(getaddr) and
  1042. ((sym^.properties and sp_static)=0) then
  1043. Message(sym_e_only_static_in_static)
  1044. else
  1045. begin
  1046. consume(ID);
  1047. do_member_read(sym,p1,pd,again);
  1048. end;
  1049. end
  1050. end
  1051. else
  1052. begin
  1053. { class reference ? }
  1054. if (pd^.deftype=objectdef)
  1055. and ((pobjectdef(pd)^.options and oois_class)<>0) then
  1056. begin
  1057. p1:=genzeronode(typen);
  1058. p1^.resulttype:=pd;
  1059. pd:=new(pclassrefdef,init(pd));
  1060. p1:=gensinglenode(loadvmtn,p1);
  1061. p1^.resulttype:=pd;
  1062. end
  1063. else
  1064. begin
  1065. { generate a type node }
  1066. { (for typeof etc) }
  1067. p1:=genzeronode(typen);
  1068. p1^.resulttype:=pd;
  1069. pd:=voiddef;
  1070. end;
  1071. end;
  1072. end;
  1073. end;
  1074. enumsym:
  1075. begin
  1076. p1:=genenumnode(penumsym(srsym));
  1077. pd:=p1^.resulttype;
  1078. end;
  1079. constsym:
  1080. begin
  1081. case pconstsym(srsym)^.consttype of
  1082. constint:
  1083. p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
  1084. conststring:
  1085. p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
  1086. constchar:
  1087. p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
  1088. constreal:
  1089. p1:=genrealconstnode(pdouble(pconstsym(srsym)^.value)^);
  1090. constbool:
  1091. p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
  1092. constseta:
  1093. p1:=gensetconstruktnode(pconstset(pconstsym(srsym)^.value),
  1094. psetdef(pconstsym(srsym)^.definition));
  1095. constord:
  1096. p1:=genordinalconstnode(pconstsym(srsym)^.value,
  1097. pconstsym(srsym)^.definition);
  1098. end;
  1099. pd:=p1^.resulttype;
  1100. end;
  1101. procsym:
  1102. begin
  1103. { are we in a class method ? }
  1104. possible_error:=(srsymtable^.symtabletype=objectsymtable) and
  1105. assigned(aktprocsym) and
  1106. ((aktprocsym^.definition^.options and poclassmethod)<>0);
  1107. p1:=gencallnode(pprocsym(srsym),srsymtable);
  1108. p1^.unit_specific:=unit_specific;
  1109. do_proc_call(getaddr,again,p1,pd);
  1110. if possible_error and
  1111. ((p1^.procdefinition^.options and poclassmethod)=0) then
  1112. Message(parser_e_only_class_methods);
  1113. end;
  1114. propertysym:
  1115. begin
  1116. { access to property in a method }
  1117. { are we in a class method ? }
  1118. if (srsymtable^.symtabletype=objectsymtable) and
  1119. assigned(aktprocsym) and
  1120. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  1121. Message(parser_e_only_class_methods);
  1122. { no method pointer }
  1123. p1:=nil;
  1124. handle_propertysym(srsym,p1,pd);
  1125. end;
  1126. errorsym:
  1127. begin
  1128. p1:=genzeronode(errorn);
  1129. pd:=generrordef;
  1130. if token=LKLAMMER then
  1131. begin
  1132. consume(LKLAMMER);
  1133. parse_paras(false,false);
  1134. consume(RKLAMMER);
  1135. end;
  1136. end;
  1137. else
  1138. begin
  1139. p1:=genzeronode(errorn);
  1140. pd:=generrordef;
  1141. Message(cg_e_illegal_expression);
  1142. end;
  1143. end;
  1144. end;
  1145. end;
  1146. { handle post fix operators }
  1147. postfixoperators;
  1148. end;
  1149. _NEW : begin
  1150. consume(_NEW);
  1151. consume(LKLAMMER);
  1152. p1:=factor(false);
  1153. if p1^.treetype<>typen then
  1154. Message(sym_e_type_id_expected);
  1155. pd:=p1^.resulttype;
  1156. pd2:=pd;
  1157. if (pd^.deftype<>pointerdef) or
  1158. (ppointerdef(pd)^.definition^.deftype<>objectdef) then
  1159. begin
  1160. Message(parser_e_pointer_to_class_expected);
  1161. { if an error occurs, read til the end of the new }
  1162. { statement }
  1163. p1:=genzeronode(errorn);
  1164. l:=1;
  1165. while true do
  1166. begin
  1167. case token of
  1168. LKLAMMER : inc(l);
  1169. RKLAMMER : dec(l);
  1170. end;
  1171. consume(token);
  1172. if l=0 then
  1173. break;
  1174. end;
  1175. end
  1176. else
  1177. begin
  1178. disposetree(p1);
  1179. p1:=genzeronode(hnewn);
  1180. p1^.resulttype:=ppointerdef(pd)^.definition;
  1181. consume(COMMA);
  1182. afterassignment:=false;
  1183. { determines the current object defintion }
  1184. classh:=pobjectdef(ppointerdef(pd)^.definition);
  1185. { check for an abstract class }
  1186. if (classh^.options and oois_abstract)<>0 then
  1187. Message(sym_e_no_instance_of_abstract_object);
  1188. { search the constructor also in the symbol tables of }
  1189. { the parents }
  1190. { no constructor found }
  1191. sym:=nil;
  1192. while assigned(classh) do
  1193. begin
  1194. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1195. srsymtable:=classh^.publicsyms;
  1196. if assigned(sym) then
  1197. break;
  1198. classh:=classh^.childof;
  1199. end;
  1200. consume(ID);
  1201. do_member_read(sym,p1,pd,again);
  1202. if (p1^.treetype<>calln) or
  1203. (assigned(p1^.procdefinition) and
  1204. ((p1^.procdefinition^.options and poconstructor)=0)) then
  1205. Message(parser_e_expr_have_to_be_constructor_call);
  1206. p1:=gensinglenode(newn,p1);
  1207. { set the resulttype }
  1208. p1^.resulttype:=pd2;
  1209. consume(RKLAMMER);
  1210. end;
  1211. end;
  1212. _SELF:
  1213. begin
  1214. again:=true;
  1215. consume(_SELF);
  1216. if not assigned(procinfo._class) then
  1217. begin
  1218. p1:=genzeronode(errorn);
  1219. pd:=generrordef;
  1220. again:=false;
  1221. Message(parser_e_self_not_in_method);
  1222. end
  1223. else
  1224. begin
  1225. if (aktprocsym^.definition^.options and poclassmethod)<>0 then
  1226. begin
  1227. { self in class methods is a class reference type }
  1228. pd:=new(pclassrefdef,init(procinfo._class));
  1229. p1:=genselfnode(pd);
  1230. p1^.resulttype:=pd;
  1231. end
  1232. else
  1233. begin
  1234. p1:=genselfnode(procinfo._class);
  1235. p1^.resulttype:=procinfo._class;
  1236. end;
  1237. pd:=p1^.resulttype;
  1238. postfixoperators;
  1239. end;
  1240. end;
  1241. _INHERITED : begin
  1242. again:=true;
  1243. consume(_INHERITED);
  1244. if assigned(procinfo._class) then
  1245. begin
  1246. classh:=procinfo._class^.childof;
  1247. while assigned(classh) do
  1248. begin
  1249. srsymtable:=pobjectdef(classh)^.publicsyms;
  1250. sym:=pvarsym(srsymtable^.search(pattern));
  1251. if assigned(sym) then
  1252. begin
  1253. p1:=genzeronode(typen);
  1254. p1^.resulttype:=classh;
  1255. pd:=p1^.resulttype;
  1256. consume(ID);
  1257. do_member_read(sym,p1,pd,again);
  1258. break;
  1259. end;
  1260. classh:=classh^.childof;
  1261. end;
  1262. if classh=nil then
  1263. begin
  1264. Message1(sym_e_id_no_member,pattern);
  1265. again:=false;
  1266. pd:=generrordef;
  1267. p1:=genzeronode(errorn);
  1268. end;
  1269. end
  1270. else
  1271. Message(parser_e_generic_methods_only_in_methods);
  1272. postfixoperators;
  1273. end;
  1274. INTCONST : begin
  1275. valint(pattern,l,code);
  1276. if code<>0 then
  1277. begin
  1278. val(pattern,d,code);
  1279. if code<>0 then
  1280. begin
  1281. Message(cg_e_invalid_integer);
  1282. l:=1;
  1283. consume(INTCONST);
  1284. p1:=genordinalconstnode(l,s32bitdef);
  1285. end
  1286. else
  1287. begin
  1288. consume(INTCONST);
  1289. p1:=genrealconstnode(d);
  1290. end;
  1291. end
  1292. else
  1293. begin
  1294. consume(INTCONST);
  1295. p1:=genordinalconstnode(l,s32bitdef);
  1296. end;
  1297. end;
  1298. REALNUMBER : begin
  1299. val(pattern,d,code);
  1300. if code<>0 then
  1301. begin
  1302. Message(parser_e_error_in_real);
  1303. d:=1.0;
  1304. end;
  1305. consume(REALNUMBER);
  1306. p1:=genrealconstnode(d);
  1307. end;
  1308. { FILE and STRING can be also a type cast }
  1309. _STRING:
  1310. begin
  1311. pd:=stringtype;
  1312. consume(LKLAMMER);
  1313. p1:=comp_expr(true);
  1314. consume(RKLAMMER);
  1315. p1:=gentypeconvnode(p1,pd);
  1316. p1^.explizit:=true;
  1317. { handle postfix operators here e.g. string(a)[10] }
  1318. again:=true;
  1319. postfixoperators;
  1320. end;
  1321. _FILE:
  1322. begin
  1323. pd:=cfiledef;
  1324. consume(_FILE);
  1325. consume(LKLAMMER);
  1326. p1:=comp_expr(true);
  1327. consume(RKLAMMER);
  1328. p1:=gentypeconvnode(p1,pd);
  1329. p1^.explizit:=true;
  1330. { handle postfix operators here e.g. string(a)[10] }
  1331. again:=true;
  1332. postfixoperators;
  1333. end;
  1334. CSTRING:
  1335. begin
  1336. p1:=genstringconstnode(pattern);
  1337. consume(CSTRING);
  1338. end;
  1339. CCHAR:
  1340. begin
  1341. p1:=genordinalconstnode(ord(pattern[1]),cchardef);
  1342. consume(CCHAR);
  1343. end;
  1344. KLAMMERAFFE : begin
  1345. consume(KLAMMERAFFE);
  1346. p1:=factor(true);
  1347. p1:=gensinglenode(addrn,p1);
  1348. end;
  1349. LKLAMMER : begin
  1350. consume(LKLAMMER);
  1351. p1:=comp_expr(true);
  1352. consume(RKLAMMER);
  1353. { it's not a good solution }
  1354. { but (a+b)^ makes some problems }
  1355. case token of
  1356. CARET,POINT,LECKKLAMMER:
  1357. begin
  1358. { we need the resulttype }
  1359. { of the expression in pd }
  1360. do_firstpass(p1);
  1361. pd:=p1^.resulttype;
  1362. again:=true;
  1363. postfixoperators;
  1364. end;
  1365. end;
  1366. end;
  1367. LECKKLAMMER : begin
  1368. consume(LECKKLAMMER);
  1369. new(constset);
  1370. for l:=0 to 31 do
  1371. constset^[l]:=0;
  1372. p2:=nil;
  1373. pd:=nil;
  1374. if token<>RECKKLAMMER then
  1375. while true do
  1376. begin
  1377. p1:=comp_expr(true);
  1378. do_firstpass(p1);
  1379. case p1^.treetype of
  1380. ordconstn : begin
  1381. if pd=nil then
  1382. pd:=p1^.resulttype;
  1383. if not(is_equal(pd,p1^.resulttype)) then
  1384. Message(parser_e_typeconflict_in_set)
  1385. else
  1386. if token=POINTPOINT then
  1387. begin
  1388. consume(POINTPOINT);
  1389. p3:=comp_expr(true);
  1390. do_firstpass(p3);
  1391. if not(is_equal(pd,p3^.resulttype)) then
  1392. Message(parser_e_typeconflict_in_set)
  1393. else
  1394. for l:=p1^.value to p3^.value do
  1395. do_set(constset,l);
  1396. disposetree(p3);
  1397. end
  1398. else
  1399. do_set(constset,p1^.value);
  1400. disposetree(p1);
  1401. end;
  1402. stringconstn : begin
  1403. if pd=nil then
  1404. pd:=cchardef;
  1405. if not(is_equal(pd,cchardef)) then
  1406. Message(parser_e_typeconflict_in_set)
  1407. else
  1408. for l:=1 to length(pstring(p1^.values)^) do
  1409. do_set(constset,ord(pstring(p1^.values)^[l]));
  1410. disposetree(p1);
  1411. end;
  1412. else
  1413. begin
  1414. if pd=nil then
  1415. pd:=p1^.resulttype;
  1416. if not(is_equal(pd,p1^.resulttype)) then
  1417. Message(parser_e_typeconflict_in_set);
  1418. p2:=gennode(setelen,p1,p2);
  1419. end;
  1420. end;
  1421. if token=COMMA then
  1422. consume(COMMA)
  1423. else break;
  1424. end;
  1425. consume(RECKKLAMMER);
  1426. p1:=gensinglenode(setconstrn,p2);
  1427. p1^.resulttype:=new(psetdef,init(pd,255));
  1428. p1^.constset:=constset;
  1429. end;
  1430. PLUS : begin
  1431. consume(PLUS);
  1432. p1:=factor(false);
  1433. end;
  1434. MINUS : begin
  1435. consume(MINUS);
  1436. p1:=factor(false);
  1437. p1:=gensinglenode(umminusn,p1);
  1438. end;
  1439. _NOT : begin
  1440. consume(_NOT);
  1441. p1:=factor(false);
  1442. p1:=gensinglenode(notn,p1);
  1443. end;
  1444. _TRUE : begin
  1445. consume(_TRUE);
  1446. p1:=genordinalconstnode(1,booldef);
  1447. end;
  1448. _FALSE : begin
  1449. consume(_FALSE);
  1450. p1:=genordinalconstnode(0,booldef);
  1451. end;
  1452. _NIL : begin
  1453. consume(_NIL);
  1454. p1:=genzeronode(niln);
  1455. end;
  1456. else
  1457. begin
  1458. p1:=genzeronode(errorn);
  1459. consume(token);
  1460. Message(cg_e_illegal_expression);
  1461. end;
  1462. end;
  1463. factor:=p1;
  1464. {$ifdef UseTokenInfo}
  1465. check_tokenpos;
  1466. {$endif UseTokenInfo}
  1467. end;
  1468. type Toperator_precedence=(opcompare,opaddition,opmultiply);
  1469. const tok2node:array[PLUS.._XOR] of Ttreetyp=
  1470. (addn,subn,muln,slashn,equaln,gtn,ltn,gten,lten,
  1471. isn,asn,inn,
  1472. symdifn,starstarn,nothingn,caretn,unequaln,nothingn,
  1473. nothingn,nothingn,nothingn,nothingn,nothingn,
  1474. nothingn,nothingn,nothingn,nothingn,nothingn,
  1475. nothingn,nothingn,nothingn,nothingn,nothingn,
  1476. nothingn,andn,nothingn,nothingn,nothingn,
  1477. nothingn,nothingn,nothingn,nothingn,nothingn,
  1478. nothingn,nothingn,divn,nothingn,nothingn,
  1479. nothingn,nothingn,nothingn,nothingn,nothingn,
  1480. nothingn,nothingn,nothingn,nothingn,nothingn,
  1481. nothingn,nothingn,nothingn,nothingn,nothingn,
  1482. modn,nothingn,nothingn,nothingn,nothingn,
  1483. nothingn,nothingn,orn,
  1484. nothingn,nothingn,nothingn,nothingn,nothingn,
  1485. nothingn,nothingn,shln,shrn,
  1486. nothingn,nothingn,nothingn,nothingn,nothingn,
  1487. nothingn,nothingn,nothingn,nothingn,nothingn,
  1488. nothingn,xorn);
  1489. operator_levels:array[Toperator_precedence] of set of Ttoken=
  1490. ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
  1491. [PLUS,MINUS,_OR,_XOR],
  1492. [CARET,SYMDIF,STARSTAR,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
  1493. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;
  1494. {Reads a subexpression while the operators are of the current precedence
  1495. level, or any higher level. Replaces the old term, simpl_expr and
  1496. simpl2_expr.}
  1497. var p1,p2:Ptree;
  1498. oldt:Ttoken;
  1499. {$ifdef UseTokenInfo}
  1500. filepos : tfileposinfo;
  1501. {$endif UseTokenInfo}
  1502. begin
  1503. { if pred_level=high(Toperator_precedence) then }
  1504. if pred_level=opmultiply then
  1505. p1:=factor(getprocvar)
  1506. else
  1507. p1:=sub_expr(succ(pred_level),true);
  1508. repeat
  1509. { aweful hack to support const a : 1..2=1; }
  1510. { disadvantage of tables :) FK }
  1511. if (token in operator_levels[pred_level]) and
  1512. ((token<>EQUAL) or accept_equal) then
  1513. begin
  1514. oldt:=token;
  1515. {$ifdef UseTokenInfo}
  1516. filepos:=tokenpos;
  1517. {$endif UseTokenInfo}
  1518. consume(token);
  1519. { if pred_level=high(Toperator_precedence) then }
  1520. if pred_level=opmultiply then
  1521. p2:=factor(getprocvar)
  1522. else
  1523. p2:=sub_expr(succ(pred_level),true);
  1524. p1:=gennode(tok2node[oldt],p1,p2);
  1525. {$ifdef UseTokenInfo}
  1526. set_tree_filepos(p1,filepos);
  1527. {$endif UseTokenInfo}
  1528. end
  1529. else
  1530. break;
  1531. until false;
  1532. sub_expr:=p1;
  1533. end;
  1534. function comp_expr(accept_equal : boolean):Ptree;
  1535. var
  1536. oldafterassignment : boolean;
  1537. begin
  1538. oldafterassignment:=afterassignment;
  1539. afterassignment:=true;
  1540. comp_expr:=sub_expr(opcompare,accept_equal);
  1541. afterassignment:=oldafterassignment;
  1542. end;
  1543. function expr : ptree;
  1544. var
  1545. p1,p2 : ptree;
  1546. oldafterassignment : boolean;
  1547. {$ifdef UseTokenInfo}
  1548. oldp1 : ptree;
  1549. filepos : tfileposinfo;
  1550. {$endif UseTokenInfo}
  1551. begin
  1552. oldafterassignment:=afterassignment;
  1553. p1:=sub_expr(opcompare,true);
  1554. if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  1555. afterassignment:=true;
  1556. {$ifdef UseTokenInfo}
  1557. filepos:=tokenpos;
  1558. oldp1:=p1;
  1559. {$endif UseTokenInfo}
  1560. case token of
  1561. POINTPOINT : begin
  1562. consume(POINTPOINT);
  1563. p2:=sub_expr(opcompare,true);
  1564. p1:=gennode(rangen,p1,p2);
  1565. end;
  1566. ASSIGNMENT : begin
  1567. consume(ASSIGNMENT);
  1568. { avoid a firstpass of a procedure if
  1569. it must be assigned to a procvar }
  1570. { should be recursive for a:=b:=c !!! }
  1571. if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
  1572. getprocvar:=true;
  1573. p2:=sub_expr(opcompare,true);
  1574. if getprocvar and (p2^.treetype=calln) then
  1575. begin
  1576. p2^.treetype:=loadn;
  1577. p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
  1578. p2^.symtableentry:=p2^.symtableprocentry;
  1579. end;
  1580. getprocvar:=false;
  1581. p1:=gennode(assignn,p1,p2);
  1582. end;
  1583. { this is the code for C like assignements }
  1584. { from an improvement of Peter Schaefer }
  1585. _PLUSASN : begin
  1586. consume(_PLUSASN );
  1587. p2:=sub_expr(opcompare,true);
  1588. p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
  1589. { was first
  1590. p1:=gennode(assignn,p1,gennode(addn,p1,p2));
  1591. but disposetree assumes that we have a real
  1592. *** tree *** }
  1593. end;
  1594. _MINUSASN : begin
  1595. consume(_MINUSASN );
  1596. p2:=sub_expr(opcompare,true);
  1597. p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
  1598. end;
  1599. _STARASN : begin
  1600. consume(_STARASN );
  1601. p2:=sub_expr(opcompare,true);
  1602. p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
  1603. end;
  1604. _SLASHASN : begin
  1605. consume(_SLASHASN );
  1606. p2:=sub_expr(opcompare,true);
  1607. p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
  1608. end;
  1609. end;
  1610. afterassignment:=oldafterassignment;
  1611. {$ifdef UseTokenInfo}
  1612. if p1<>oldp1 then
  1613. set_tree_filepos(p1,filepos);
  1614. {$endif UseTokenInfo}
  1615. expr:=p1;
  1616. end;
  1617. function get_intconst:longint;
  1618. {Reads an expression, tries to evalute it and check if it is an integer
  1619. constant. Then the constant is returned.}
  1620. var p:Ptree;
  1621. begin
  1622. p:=comp_expr(true);
  1623. do_firstpass(p);
  1624. if (p^.treetype<>ordconstn) and
  1625. (p^.resulttype^.deftype=orddef) and
  1626. not (Porddef(p^.resulttype)^.typ in
  1627. [uvoid,uchar,bool8bit]) then
  1628. Message(cg_e_illegal_expression)
  1629. else
  1630. get_intconst:=p^.value;
  1631. disposetree(p);
  1632. end;
  1633. function get_stringconst:string;
  1634. {Reads an expression, tries to evaluate it and checks if it is a string
  1635. constant. Then the constant is returned.}
  1636. var p:Ptree;
  1637. begin
  1638. get_stringconst:='';
  1639. p:=comp_expr(true);
  1640. do_firstpass(p);
  1641. if p^.treetype<>stringconstn then
  1642. if (p^.treetype=ordconstn) and
  1643. (p^.resulttype^.deftype=orddef) and
  1644. (Porddef(p^.resulttype)^.typ=uchar) then
  1645. get_stringconst:=char(p^.value)
  1646. else
  1647. Message(cg_e_illegal_expression)
  1648. else
  1649. get_stringconst:=p^.values^;
  1650. disposetree(p);
  1651. end;
  1652. end.
  1653. {
  1654. $Log$
  1655. Revision 1.14 1998-05-11 13:07:56 peter
  1656. + $ifdef NEWPPU for the new ppuformat
  1657. + $define GDB not longer required
  1658. * removed all warnings and stripped some log comments
  1659. * no findfirst/findnext anymore to remove smartlink *.o files
  1660. Revision 1.13 1998/05/06 08:38:45 pierre
  1661. * better position info with UseTokenInfo
  1662. UseTokenInfo greatly simplified
  1663. + added check for changed tree after first time firstpass
  1664. (if we could remove all the cases were it happen
  1665. we could skip all firstpass if firstpasscount > 1)
  1666. Only with ExtDebug
  1667. Revision 1.12 1998/05/05 12:05:42 florian
  1668. * problems with properties fixed
  1669. * crash fixed: i:=l when i and l are undefined, was a problem with
  1670. implementation of private/protected
  1671. Revision 1.11 1998/05/04 11:22:26 florian
  1672. * problem with DOM solved: it crashes when accessing a property in a method
  1673. Revision 1.10 1998/05/01 16:38:45 florian
  1674. * handling of private and protected fixed
  1675. + change_keywords_to_tp implemented to remove
  1676. keywords which aren't supported by tp
  1677. * break and continue are now symbols of the system unit
  1678. + widestring, longstring and ansistring type released
  1679. Revision 1.9 1998/04/29 10:33:58 pierre
  1680. + added some code for ansistring (not complete nor working yet)
  1681. * corrected operator overloading
  1682. * corrected nasm output
  1683. + started inline procedures
  1684. + added starstarn : use ** for exponentiation (^ gave problems)
  1685. + started UseTokenInfo cond to get accurate positions
  1686. Revision 1.8 1998/04/14 23:27:03 florian
  1687. + exclude/include with constant second parameter added
  1688. Revision 1.7 1998/04/09 23:02:15 florian
  1689. * small problems solved to get remake3 work
  1690. Revision 1.6 1998/04/09 22:16:35 florian
  1691. * problem with previous REGALLOC solved
  1692. * improved property support
  1693. Revision 1.5 1998/04/08 10:26:09 florian
  1694. * correct error handling of virtual constructors
  1695. * problem with new type declaration handling fixed
  1696. Revision 1.4 1998/04/07 22:45:05 florian
  1697. * bug0092, bug0115 and bug0121 fixed
  1698. + packed object/class/array
  1699. Revision 1.3 1998/04/07 13:19:46 pierre
  1700. * bugfixes for reset_gdb_info
  1701. in MEM parsing for go32v2
  1702. better external symbol creation
  1703. support for rhgdb.exe (lowercase file names)
  1704. }