pexpr.pas 77 KB

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