pexpr.pas 95 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574
  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(getaddr : boolean;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. globtype,systems,tokens,
  35. cobjects,globals,scanner,aasm,pass_1,
  36. hcodegen,types,verbose,strings
  37. {$ifndef newcg}
  38. ,tccal
  39. {$endif newcg}
  40. { parser specific stuff }
  41. ,pbase,pdecl
  42. { processor specific stuff }
  43. {$ifdef i386}
  44. ,i386base
  45. {$endif}
  46. {$ifdef m68k}
  47. ,m68k
  48. {$endif}
  49. ;
  50. const
  51. allow_type : boolean = true;
  52. got_addrn : boolean = false;
  53. function parse_paras(_colon,in_prop_paras : boolean) : ptree;
  54. var
  55. p1,p2 : ptree;
  56. end_of_paras : ttoken;
  57. begin
  58. if in_prop_paras then
  59. end_of_paras:=RECKKLAMMER
  60. else
  61. end_of_paras:=RKLAMMER;
  62. if token=end_of_paras then
  63. begin
  64. parse_paras:=nil;
  65. exit;
  66. end;
  67. p2:=nil;
  68. inc(parsing_para_level);
  69. while true do
  70. begin
  71. p1:=comp_expr(true);
  72. p2:=gencallparanode(p1,p2);
  73. { it's for the str(l:5,s); }
  74. if _colon and (token=COLON) then
  75. begin
  76. consume(COLON);
  77. p1:=comp_expr(true);
  78. p2:=gencallparanode(p1,p2);
  79. p2^.is_colon_para:=true;
  80. if token=COLON then
  81. begin
  82. consume(COLON);
  83. p1:=comp_expr(true);
  84. p2:=gencallparanode(p1,p2);
  85. p2^.is_colon_para:=true;
  86. end
  87. end;
  88. if token=COMMA then
  89. consume(COMMA)
  90. else
  91. break;
  92. end;
  93. dec(parsing_para_level);
  94. parse_paras:=p2;
  95. end;
  96. procedure check_tp_procvar(var p : ptree);
  97. var
  98. p1 : ptree;
  99. Store_valid : boolean;
  100. begin
  101. if (m_tp_procvar in aktmodeswitches) and
  102. (not got_addrn) and
  103. (not in_args) and
  104. (p^.treetype=loadn) then
  105. begin
  106. { support if procvar then for tp7 and many other expression like this }
  107. Store_valid:=Must_be_valid;
  108. Must_be_valid:=false;
  109. do_firstpass(p);
  110. Must_be_valid:=Store_valid;
  111. if not(getprocvar) and (p^.resulttype^.deftype=procvardef) then
  112. begin
  113. p1:=gencallnode(nil,nil);
  114. p1^.right:=p;
  115. p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef;
  116. firstpass(p1);
  117. p:=p1;
  118. end;
  119. end;
  120. end;
  121. function statement_syssym(l : longint;var pd : pdef) : ptree;
  122. var
  123. p1,p2,paras : ptree;
  124. prev_in_args : boolean;
  125. Store_valid : boolean;
  126. begin
  127. prev_in_args:=in_args;
  128. Store_valid:=Must_be_valid;
  129. case l of
  130. in_ord_x :
  131. begin
  132. consume(LKLAMMER);
  133. in_args:=true;
  134. Must_be_valid:=true;
  135. p1:=comp_expr(true);
  136. consume(RKLAMMER);
  137. do_firstpass(p1);
  138. p1:=geninlinenode(in_ord_x,false,p1);
  139. do_firstpass(p1);
  140. statement_syssym := p1;
  141. pd:=p1^.resulttype;
  142. end;
  143. in_break :
  144. begin
  145. statement_syssym:=genzeronode(breakn);
  146. pd:=voiddef;
  147. end;
  148. in_continue :
  149. begin
  150. statement_syssym:=genzeronode(continuen);
  151. pd:=voiddef;
  152. end;
  153. in_typeof_x :
  154. begin
  155. consume(LKLAMMER);
  156. in_args:=true;
  157. {allow_type:=true;}
  158. p1:=comp_expr(true);
  159. {allow_type:=false;}
  160. consume(RKLAMMER);
  161. pd:=voidpointerdef;
  162. if p1^.treetype=typen then
  163. begin
  164. if (p1^.typenodetype=nil) then
  165. begin
  166. Message(type_e_mismatch);
  167. statement_syssym:=genzeronode(errorn);
  168. end
  169. else
  170. if p1^.typenodetype^.deftype=objectdef then
  171. begin
  172. { we can use resulttype in pass_2 (PM) }
  173. p1^.resulttype:=p1^.typenodetype;
  174. statement_syssym:=geninlinenode(in_typeof_x,false,p1);
  175. end
  176. else
  177. begin
  178. Message(type_e_mismatch);
  179. disposetree(p1);
  180. statement_syssym:=genzeronode(errorn);
  181. end;
  182. end
  183. else { not a type node }
  184. begin
  185. Must_be_valid:=false;
  186. do_firstpass(p1);
  187. if (p1^.resulttype=nil) then
  188. begin
  189. Message(type_e_mismatch);
  190. disposetree(p1);
  191. statement_syssym:=genzeronode(errorn)
  192. end
  193. else
  194. if p1^.resulttype^.deftype=objectdef then
  195. statement_syssym:=geninlinenode(in_typeof_x,false,p1)
  196. else
  197. begin
  198. Message(type_e_mismatch);
  199. statement_syssym:=genzeronode(errorn);
  200. disposetree(p1);
  201. end;
  202. end;
  203. end;
  204. in_sizeof_x :
  205. begin
  206. consume(LKLAMMER);
  207. in_args:=true;
  208. {allow_type:=true;}
  209. p1:=comp_expr(true);
  210. {allow_type:=false; }
  211. consume(RKLAMMER);
  212. pd:=s32bitdef;
  213. if p1^.treetype=typen then
  214. begin
  215. statement_syssym:=genordinalconstnode(p1^.typenodetype^.size,pd);
  216. { p1 not needed !}
  217. disposetree(p1);
  218. end
  219. else
  220. begin
  221. Must_be_valid:=false;
  222. do_firstpass(p1);
  223. if ((p1^.resulttype^.deftype=objectdef) and
  224. ((pobjectdef(p1^.resulttype)^.options and oo_hasconstructor)<>0)) or
  225. is_open_array(p1^.resulttype) or
  226. is_open_string(p1^.resulttype) then
  227. statement_syssym:=geninlinenode(in_sizeof_x,false,p1)
  228. else
  229. begin
  230. statement_syssym:=genordinalconstnode(p1^.resulttype^.size,pd);
  231. { p1 not needed !}
  232. disposetree(p1);
  233. end;
  234. end;
  235. end;
  236. in_assigned_x :
  237. begin
  238. consume(LKLAMMER);
  239. in_args:=true;
  240. p1:=comp_expr(true);
  241. Must_be_valid:=true;
  242. do_firstpass(p1);
  243. case p1^.resulttype^.deftype of
  244. pointerdef,
  245. procvardef,
  246. classrefdef : ;
  247. objectdef : if not(pobjectdef(p1^.resulttype)^.isclass) then
  248. Message(parser_e_illegal_parameter_list);
  249. else
  250. Message(parser_e_illegal_parameter_list);
  251. end;
  252. p2:=gencallparanode(p1,nil);
  253. p2:=geninlinenode(in_assigned_x,false,p2);
  254. consume(RKLAMMER);
  255. pd:=booldef;
  256. statement_syssym:=p2;
  257. end;
  258. in_ofs_x :
  259. begin
  260. consume(LKLAMMER);
  261. in_args:=true;
  262. p1:=comp_expr(true);
  263. p1:=gensinglenode(addrn,p1);
  264. Must_be_valid:=false;
  265. do_firstpass(p1);
  266. { Ofs() returns a longint, not a pointer }
  267. p1^.resulttype:=u32bitdef;
  268. pd:=p1^.resulttype;
  269. consume(RKLAMMER);
  270. statement_syssym:=p1;
  271. end;
  272. in_addr_x :
  273. begin
  274. consume(LKLAMMER);
  275. in_args:=true;
  276. p1:=comp_expr(true);
  277. p1:=gensinglenode(addrn,p1);
  278. Must_be_valid:=false;
  279. do_firstpass(p1);
  280. pd:=p1^.resulttype;
  281. consume(RKLAMMER);
  282. statement_syssym:=p1;
  283. end;
  284. in_seg_x :
  285. begin
  286. consume(LKLAMMER);
  287. in_args:=true;
  288. p1:=comp_expr(true);
  289. do_firstpass(p1);
  290. if p1^.location.loc<>LOC_REFERENCE then
  291. Message(cg_e_illegal_expression);
  292. p1:=genordinalconstnode(0,s32bitdef);
  293. Must_be_valid:=false;
  294. pd:=s32bitdef;
  295. consume(RKLAMMER);
  296. statement_syssym:=p1;
  297. end;
  298. in_high_x,
  299. in_low_x :
  300. begin
  301. consume(LKLAMMER);
  302. in_args:=true;
  303. {allow_type:=true;}
  304. p1:=comp_expr(true);
  305. {allow_type:=false;}
  306. do_firstpass(p1);
  307. if p1^.treetype=typen then
  308. p1^.resulttype:=p1^.typenodetype;
  309. Must_be_valid:=false;
  310. p2:=geninlinenode(l,false,p1);
  311. consume(RKLAMMER);
  312. pd:=s32bitdef;
  313. statement_syssym:=p2;
  314. end;
  315. in_succ_x,
  316. in_pred_x :
  317. begin
  318. consume(LKLAMMER);
  319. in_args:=true;
  320. p1:=comp_expr(true);
  321. do_firstpass(p1);
  322. Must_be_valid:=false;
  323. p2:=geninlinenode(l,false,p1);
  324. consume(RKLAMMER);
  325. pd:=p1^.resulttype;
  326. statement_syssym:=p2;
  327. end;
  328. in_inc_x,
  329. in_dec_x :
  330. begin
  331. consume(LKLAMMER);
  332. in_args:=true;
  333. p1:=comp_expr(true);
  334. Must_be_valid:=false;
  335. if token=COMMA then
  336. begin
  337. consume(COMMA);
  338. p2:=gencallparanode(comp_expr(true),nil);
  339. end
  340. else
  341. p2:=nil;
  342. p2:=gencallparanode(p1,p2);
  343. statement_syssym:=geninlinenode(l,false,p2);
  344. consume(RKLAMMER);
  345. pd:=voiddef;
  346. end;
  347. in_concat_x :
  348. begin
  349. consume(LKLAMMER);
  350. in_args:=true;
  351. p2:=nil;
  352. while true do
  353. begin
  354. p1:=comp_expr(true);
  355. Must_be_valid:=true;
  356. do_firstpass(p1);
  357. if not((p1^.resulttype^.deftype=stringdef) or
  358. ((p1^.resulttype^.deftype=orddef) and
  359. (porddef(p1^.resulttype)^.typ=uchar))) then
  360. Message(parser_e_illegal_parameter_list);
  361. if p2<>nil then
  362. p2:=gennode(addn,p2,p1)
  363. else
  364. p2:=p1;
  365. if token=COMMA then
  366. consume(COMMA)
  367. else
  368. break;
  369. end;
  370. consume(RKLAMMER);
  371. pd:=cshortstringdef;
  372. statement_syssym:=p2;
  373. end;
  374. in_read_x,
  375. in_readln_x :
  376. begin
  377. if token=LKLAMMER then
  378. begin
  379. consume(LKLAMMER);
  380. in_args:=true;
  381. Must_be_valid:=false;
  382. paras:=parse_paras(false,false);
  383. consume(RKLAMMER);
  384. end
  385. else
  386. paras:=nil;
  387. pd:=voiddef;
  388. p1:=geninlinenode(l,false,paras);
  389. do_firstpass(p1);
  390. statement_syssym := p1;
  391. end;
  392. in_write_x,
  393. in_writeln_x :
  394. begin
  395. if token=LKLAMMER then
  396. begin
  397. consume(LKLAMMER);
  398. in_args:=true;
  399. Must_be_valid:=true;
  400. paras:=parse_paras(true,false);
  401. consume(RKLAMMER);
  402. end
  403. else
  404. paras:=nil;
  405. pd:=voiddef;
  406. p1 := geninlinenode(l,false,paras);
  407. do_firstpass(p1);
  408. statement_syssym := p1;
  409. end;
  410. in_str_x_string :
  411. begin
  412. consume(LKLAMMER);
  413. in_args:=true;
  414. paras:=parse_paras(true,false);
  415. consume(RKLAMMER);
  416. p1 := geninlinenode(l,false,paras);
  417. do_firstpass(p1);
  418. statement_syssym := p1;
  419. pd:=voiddef;
  420. end;
  421. in_val_x:
  422. Begin
  423. consume(LKLAMMER);
  424. in_args := true;
  425. p1:= gencallparanode(comp_expr(true), nil);
  426. Must_be_valid := False;
  427. consume(COMMA);
  428. p2 := gencallparanode(comp_expr(true),p1);
  429. if (token = COMMA) then
  430. Begin
  431. consume(COMMA);
  432. p2 := gencallparanode(comp_expr(true),p2)
  433. End;
  434. consume(RKLAMMER);
  435. p2 := geninlinenode(l,false,p2);
  436. do_firstpass(p2);
  437. statement_syssym := p2;
  438. pd := voiddef;
  439. End;
  440. in_include_x_y,
  441. in_exclude_x_y :
  442. begin
  443. consume(LKLAMMER);
  444. in_args:=true;
  445. p1:=comp_expr(true);
  446. Must_be_valid:=false;
  447. consume(COMMA);
  448. p2:=comp_expr(true);
  449. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  450. consume(RKLAMMER);
  451. pd:=voiddef;
  452. end;
  453. in_assert_x_y :
  454. begin
  455. consume(LKLAMMER);
  456. in_args:=true;
  457. p1:=comp_expr(true);
  458. if token=COMMA then
  459. begin
  460. consume(COMMA);
  461. p2:=comp_expr(true);
  462. end
  463. else
  464. begin
  465. { then insert an empty string }
  466. p2:=genstringconstnode('');
  467. end;
  468. statement_syssym:=geninlinenode(l,false,gencallparanode(p1,gencallparanode(p2,nil)));
  469. consume(RKLAMMER);
  470. pd:=voiddef;
  471. end;
  472. else
  473. internalerror(15);
  474. end;
  475. in_args:=prev_in_args;
  476. Must_be_valid:=Store_valid;
  477. end;
  478. { reads the parameter for a subroutine call }
  479. procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
  480. var
  481. prev_in_args : boolean;
  482. prevafterassn : boolean;
  483. begin
  484. prev_in_args:=in_args;
  485. prevafterassn:=afterassignment;
  486. afterassignment:=false;
  487. { want we only determine the address of }
  488. { a subroutine ? }
  489. if not(getaddr) then
  490. begin
  491. if token=LKLAMMER then
  492. begin
  493. consume(LKLAMMER);
  494. in_args:=true;
  495. p1^.left:=parse_paras(false,false);
  496. consume(RKLAMMER);
  497. end
  498. else p1^.left:=nil;
  499. { do firstpass because we need the }
  500. { result type }
  501. do_firstpass(p1);
  502. end
  503. else
  504. begin
  505. { address operator @: }
  506. p1^.left:=nil;
  507. { forget pd }
  508. pd:=nil;
  509. if (p1^.symtableproc^.symtabletype=withsymtable) and
  510. (p1^.symtableproc^.defowner^.deftype=objectdef) then
  511. begin
  512. p1^.methodpointer:=getcopy(pwithsymtable(p1^.symtableproc)^.withrefnode);
  513. end
  514. else if not(assigned(p1^.methodpointer)) then
  515. begin
  516. { we must provide a method pointer, if it isn't given, }
  517. { it is self }
  518. p1^.methodpointer:=genselfnode(procinfo._class);
  519. p1^.methodpointer^.resulttype:=procinfo._class;
  520. end;
  521. { no postfix operators }
  522. again:=false;
  523. end;
  524. pd:=p1^.resulttype;
  525. in_args:=prev_in_args;
  526. afterassignment:=prevafterassn;
  527. end;
  528. procedure handle_procvar(procvar : pprocvardef;var t : ptree);
  529. var
  530. hp : ptree;
  531. begin
  532. hp:=nil;
  533. if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then
  534. begin
  535. if ((procvar^.options and pomethodpointer)<>0) then
  536. hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer))
  537. else
  538. hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable);
  539. end;
  540. if assigned(hp) then
  541. begin
  542. disposetree(t);
  543. t:=hp;
  544. end;
  545. end;
  546. { the following procedure handles the access to a property symbol }
  547. procedure handle_propertysym(sym : psym;st : psymtable;var p1 : ptree;
  548. var pd : pdef);
  549. var
  550. paras : ptree;
  551. p2 : ptree;
  552. begin
  553. paras:=nil;
  554. { property parameters? }
  555. if token=LECKKLAMMER then
  556. begin
  557. consume(LECKKLAMMER);
  558. paras:=parse_paras(false,true);
  559. consume(RECKKLAMMER);
  560. end;
  561. { indexed property }
  562. if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
  563. begin
  564. p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
  565. paras:=gencallparanode(p2,paras);
  566. end;
  567. { we need only a write property if a := follows }
  568. { if not(afterassignment) and not(in_args) then }
  569. if token=ASSIGNMENT then
  570. begin
  571. { write property: }
  572. { no result }
  573. pd:=voiddef;
  574. if assigned(ppropertysym(sym)^.writeaccesssym) then
  575. begin
  576. if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
  577. begin
  578. { generate the method call }
  579. p1:=genmethodcallnode(pprocsym(
  580. ppropertysym(sym)^.writeaccesssym),st,p1);
  581. { we know the procedure to call, so
  582. force the usage of that procedure }
  583. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccessdef);
  584. p1^.left:=paras;
  585. consume(ASSIGNMENT);
  586. { read the expression }
  587. getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef;
  588. p2:=comp_expr(true);
  589. if getprocvar then
  590. begin
  591. if (p2^.treetype=calln) then
  592. handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2)
  593. else
  594. if (p2^.treetype=typeconvn) and
  595. (p2^.left^.treetype=calln) then
  596. handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2^.left);
  597. end;
  598. p1^.left:=gencallparanode(p2,p1^.left);
  599. getprocvar:=false;
  600. end
  601. else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
  602. begin
  603. if assigned(paras) then
  604. message(parser_e_no_paras_allowed);
  605. { subscribed access? }
  606. if p1=nil then
  607. p1:=genloadnode(pvarsym(ppropertysym(sym)^.writeaccesssym),st)
  608. else
  609. p1:=gensubscriptnode(pvarsym(ppropertysym(sym)^.writeaccesssym),p1);
  610. consume(ASSIGNMENT);
  611. { read the expression }
  612. p2:=comp_expr(true);
  613. p1:=gennode(assignn,p1,p2);
  614. end
  615. else
  616. begin
  617. p1:=genzeronode(errorn);
  618. Message(parser_e_no_procedure_to_access_property);
  619. end;
  620. end
  621. else
  622. begin
  623. p1:=genzeronode(errorn);
  624. Message(parser_e_no_procedure_to_access_property);
  625. end;
  626. end
  627. else
  628. begin
  629. { read property: }
  630. pd:=ppropertysym(sym)^.proptype;
  631. if assigned(ppropertysym(sym)^.readaccesssym) then
  632. begin
  633. if ppropertysym(sym)^.readaccesssym^.typ=varsym then
  634. begin
  635. if assigned(paras) then
  636. message(parser_e_no_paras_allowed);
  637. { subscribed access? }
  638. if p1=nil then
  639. p1:=genloadnode(pvarsym(ppropertysym(sym)^.readaccesssym),st)
  640. else
  641. p1:=gensubscriptnode(pvarsym(ppropertysym(sym)^.readaccesssym),p1);
  642. end
  643. else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
  644. begin
  645. { generate the method call }
  646. p1:=genmethodcallnode(pprocsym(ppropertysym(sym)^.readaccesssym),st,p1);
  647. { we know the procedure to call, so
  648. force the usage of that procedure }
  649. p1^.procdefinition:=pprocdef(ppropertysym(sym)^.readaccessdef);
  650. { insert paras }
  651. p1^.left:=paras;
  652. end
  653. else
  654. begin
  655. p1:=genzeronode(errorn);
  656. Message(type_e_mismatch);
  657. end;
  658. end
  659. else
  660. begin
  661. { error, no function to read property }
  662. p1:=genzeronode(errorn);
  663. Message(parser_e_no_procedure_to_access_property);
  664. end;
  665. end;
  666. end;
  667. { the ID token has to be consumed before calling this function }
  668. procedure do_member_read(getaddr : boolean;const sym : psym;var p1 : ptree;
  669. var pd : pdef;var again : boolean);
  670. var
  671. static_name : string;
  672. isclassref : boolean;
  673. begin
  674. if sym=nil then
  675. begin
  676. { pattern is still valid unless
  677. there is another ID just after the ID of sym }
  678. Message1(sym_e_id_no_member,pattern);
  679. disposetree(p1);
  680. p1:=genzeronode(errorn);
  681. { try to clean up }
  682. pd:=generrordef;
  683. again:=false;
  684. end
  685. else
  686. begin
  687. isclassref:=pd^.deftype=classrefdef;
  688. { check protected and private members }
  689. { please leave this code as it is, }
  690. { it has now the same behaviaor as TP/Delphi }
  691. if ((sym^.properties and sp_private)<>0) and
  692. (pobjectdef(pd)^.owner^.symtabletype=unitsymtable) then
  693. Message(parser_e_cant_access_private_member);
  694. if ((sym^.properties and sp_protected)<>0) and
  695. (pobjectdef(pd)^.owner^.symtabletype=unitsymtable) then
  696. begin
  697. if assigned(aktprocsym^.definition^._class) then
  698. begin
  699. if not aktprocsym^.definition^._class^.isrelated(
  700. pobjectdef(sym^.owner^.defowner)) then
  701. Message(parser_e_cant_access_protected_member);
  702. end
  703. else
  704. Message(parser_e_cant_access_protected_member);
  705. end;
  706. { we assume, that only procsyms and varsyms are in an object }
  707. { symbol table, for classes, properties are allowed }
  708. case sym^.typ of
  709. procsym:
  710. begin
  711. p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
  712. do_proc_call(getaddr or
  713. (getprocvar and
  714. (m_tp_procvar in aktmodeswitches) and
  715. proc_to_procvar_equal(pprocsym(sym)^.definition,getprocvardef))
  716. ,again,p1,pd);
  717. { now we know the real method e.g. we can check for }
  718. { a class method }
  719. if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
  720. Message(parser_e_only_class_methods_via_class_ref);
  721. end;
  722. varsym:
  723. begin
  724. if isclassref then
  725. Message(parser_e_only_class_methods_via_class_ref);
  726. if (sym^.properties and sp_static)<>0 then
  727. begin
  728. { static_name:=lower(srsymtable^.name^)+'_'+sym^.name;
  729. this is wrong for static field in with symtable (PM) }
  730. static_name:=lower(srsym^.owner^.name^)+'_'+sym^.name;
  731. getsym(static_name,true);
  732. disposetree(p1);
  733. p1:=genloadnode(pvarsym(srsym),srsymtable);
  734. end
  735. else
  736. p1:=gensubscriptnode(pvarsym(sym),p1);
  737. pd:=pvarsym(sym)^.definition;
  738. end;
  739. propertysym:
  740. begin
  741. if isclassref then
  742. Message(parser_e_only_class_methods_via_class_ref);
  743. handle_propertysym(sym,srsymtable,p1,pd);
  744. end;
  745. else internalerror(16);
  746. end;
  747. end;
  748. end;
  749. {****************************************************************************
  750. Factor
  751. ****************************************************************************}
  752. function factor(getaddr : boolean) : ptree;
  753. var
  754. l : longint;
  755. oldp1,
  756. p1,p2,p3 : ptree;
  757. code : integer;
  758. pd,pd2 : pdef;
  759. possible_error,
  760. unit_specific,
  761. again : boolean;
  762. sym : pvarsym;
  763. classh : pobjectdef;
  764. d : bestreal;
  765. static_name : string;
  766. propsym : ppropertysym;
  767. filepos : tfileposinfo;
  768. {---------------------------------------------
  769. Is_func_ret
  770. ---------------------------------------------}
  771. function is_func_ret(sym : psym) : boolean;
  772. var
  773. p : pprocinfo;
  774. storesymtablestack : psymtable;
  775. begin
  776. is_func_ret:=false;
  777. if (sym^.typ<>funcretsym) and ((procinfo.flags and pi_operator)=0) then
  778. exit;
  779. p:=@procinfo;
  780. while system.assigned(p) do
  781. begin
  782. { is this an access to a function result ? }
  783. if assigned(p^.funcretsym) and
  784. ((pfuncretsym(sym)=p^.funcretsym) or
  785. ((pvarsym(sym)=opsym) and
  786. ((p^.flags and pi_operator)<>0))) and
  787. (p^.retdef<>pdef(voiddef)) and
  788. (token<>LKLAMMER) and
  789. (not ((m_tp in aktmodeswitches) and
  790. (afterassignment or in_args))) then
  791. begin
  792. if ((pvarsym(sym)=opsym) and
  793. ((p^.flags and pi_operator)<>0)) then
  794. inc(opsym^.refs);
  795. if ((pvarsym(sym)=opsym) and
  796. ((p^.flags and pi_operator)<>0)) then
  797. inc(opsym^.refs);
  798. p1:=genzeronode(funcretn);
  799. pd:=p^.retdef;
  800. p1^.funcretprocinfo:=p;
  801. p1^.retdef:=pd;
  802. is_func_ret:=true;
  803. exit;
  804. end;
  805. p:=p^.parent;
  806. end;
  807. { we must use the function call }
  808. if(sym^.typ=funcretsym) then
  809. begin
  810. storesymtablestack:=symtablestack;
  811. symtablestack:=srsymtable^.next;
  812. getsym(sym^.name,true);
  813. if srsym^.typ<>procsym then
  814. Message(cg_e_illegal_expression);
  815. symtablestack:=storesymtablestack;
  816. end;
  817. end;
  818. {---------------------------------------------
  819. Factor_read_id
  820. ---------------------------------------------}
  821. procedure factor_read_id;
  822. var
  823. pc : pchar;
  824. len : longint;
  825. begin
  826. { allow post fix operators }
  827. again:=true;
  828. if (m_result in aktmodeswitches) and
  829. (idtoken=_RESULT) and
  830. assigned(aktprocsym) and
  831. (procinfo.retdef<>pdef(voiddef)) then
  832. begin
  833. consume(ID);
  834. p1:=genzeronode(funcretn);
  835. pd:=procinfo.retdef;
  836. p1^.funcretprocinfo:=pointer(@procinfo);
  837. p1^.retdef:=pd;
  838. end
  839. else
  840. begin
  841. if lastsymknown then
  842. begin
  843. srsym:=lastsrsym;
  844. srsymtable:=lastsrsymtable;
  845. lastsymknown:=false;
  846. end
  847. else
  848. getsym(pattern,true);
  849. consume(ID);
  850. if not is_func_ret(srsym) then
  851. { else it's a normal symbol }
  852. begin
  853. { is it defined like UNIT.SYMBOL ? }
  854. if srsym^.typ=unitsym then
  855. begin
  856. consume(POINT);
  857. getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  858. unit_specific:=true;
  859. consume(ID);
  860. end
  861. else
  862. unit_specific:=false;
  863. if not assigned(srsym) then
  864. Begin
  865. p1:=genzeronode(errorn);
  866. { try to clean up }
  867. pd:=generrordef;
  868. end
  869. else
  870. Begin
  871. { check semantics of private }
  872. if (srsym^.typ in [propertysym,procsym,varsym]) and
  873. (srsymtable^.symtabletype=objectsymtable) then
  874. begin
  875. if ((srsym^.properties and sp_private)<>0) and
  876. (pobjectdef(srsym^.owner^.defowner)^.owner^.symtabletype=unitsymtable) then
  877. Message(parser_e_cant_access_private_member);
  878. end;
  879. case srsym^.typ of
  880. absolutesym : begin
  881. p1:=genloadnode(pvarsym(srsym),srsymtable);
  882. pd:=pabsolutesym(srsym)^.definition;
  883. end;
  884. varsym : begin
  885. { are we in a class method ? }
  886. if (srsymtable^.symtabletype=objectsymtable) and
  887. assigned(aktprocsym) and
  888. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  889. Message(parser_e_only_class_methods);
  890. if (srsym^.properties and sp_static)<>0 then
  891. begin
  892. static_name:=lower(srsym^.owner^.name^)+'_'+srsym^.name;
  893. getsym(static_name,true);
  894. end;
  895. p1:=genloadnode(pvarsym(srsym),srsymtable);
  896. if pvarsym(srsym)^.is_valid=0 then
  897. begin
  898. p1^.is_first := true;
  899. { set special between first loaded until checked in firstpass }
  900. pvarsym(srsym)^.is_valid:=2;
  901. end;
  902. pd:=pvarsym(srsym)^.definition;
  903. end;
  904. typedconstsym : begin
  905. p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
  906. pd:=ptypedconstsym(srsym)^.definition;
  907. end;
  908. syssym : p1:=statement_syssym(psyssym(srsym)^.number,pd);
  909. typesym : begin
  910. pd:=ptypesym(srsym)^.definition;
  911. if not assigned(pd) then
  912. begin
  913. pd:=generrordef;
  914. again:=false;
  915. end
  916. else
  917. begin
  918. { if we read a type declaration }
  919. { we have to return the type and }
  920. { nothing else }
  921. if block_type=bt_type then
  922. begin
  923. { we don't need sym reference when it's in the
  924. current unit or system unit, because those
  925. units are always loaded (PFV) }
  926. if (pd^.owner^.unitid=0) or
  927. (pd^.owner^.unitid=1) then
  928. p1:=gentypenode(pd,nil)
  929. else
  930. p1:=gentypenode(pd,ptypesym(srsym));
  931. { here we can also set resulttype !! }
  932. p1^.resulttype:=pd;
  933. pd:=voiddef;
  934. end
  935. else { not type block }
  936. begin
  937. if token=LKLAMMER then
  938. begin
  939. consume(LKLAMMER);
  940. p1:=comp_expr(true);
  941. consume(RKLAMMER);
  942. p1:=gentypeconvnode(p1,pd);
  943. p1^.explizit:=true;
  944. end
  945. else { not LKLAMMER}
  946. if (token=POINT) and
  947. (pd^.deftype=objectdef) and
  948. not(pobjectdef(pd)^.isclass) then
  949. begin
  950. consume(POINT);
  951. if assigned(procinfo._class) then
  952. begin
  953. if procinfo._class^.isrelated(pobjectdef(pd)) then
  954. begin
  955. p1:=gentypenode(pd,ptypesym(srsym));
  956. p1^.resulttype:=pd;
  957. srsymtable:=pobjectdef(pd)^.publicsyms;
  958. sym:=pvarsym(srsymtable^.search(pattern));
  959. { search also in inherited methods }
  960. while sym=nil do
  961. begin
  962. pd:=pobjectdef(pd)^.childof;
  963. srsymtable:=pobjectdef(pd)^.publicsyms;
  964. sym:=pvarsym(srsymtable^.search(pattern));
  965. end;
  966. consume(ID);
  967. do_member_read(false,sym,p1,pd,again);
  968. end
  969. else
  970. begin
  971. Message(parser_e_no_super_class);
  972. pd:=generrordef;
  973. again:=false;
  974. end;
  975. end
  976. else
  977. begin
  978. { allows @TObject.Load }
  979. { also allows static methods and variables }
  980. p1:=genzeronode(typen);
  981. p1^.resulttype:=pd;
  982. { srsymtable:=pobjectdef(pd)^.publicsyms;
  983. sym:=pvarsym(srsymtable^.search(pattern)); }
  984. { TP allows also @TMenu.Load if Load is only }
  985. { defined in an anchestor class }
  986. sym:=pvarsym(search_class_member(pobjectdef(pd),pattern));
  987. if not assigned(sym) then
  988. Message1(sym_e_id_no_member,pattern)
  989. else if not(getaddr) and ((sym^.properties and sp_static)=0) then
  990. Message(sym_e_only_static_in_static)
  991. else
  992. begin
  993. consume(ID);
  994. do_member_read(getaddr,sym,p1,pd,again);
  995. end;
  996. end;
  997. end
  998. else
  999. begin
  1000. { class reference ? }
  1001. if (pd^.deftype=objectdef)
  1002. and pobjectdef(pd)^.isclass then
  1003. begin
  1004. p1:=gentypenode(pd,nil);
  1005. p1^.resulttype:=pd;
  1006. pd:=new(pclassrefdef,init(pd));
  1007. p1:=gensinglenode(loadvmtn,p1);
  1008. p1^.resulttype:=pd;
  1009. end
  1010. else
  1011. begin
  1012. { generate a type node }
  1013. { (for typeof etc) }
  1014. if allow_type then
  1015. begin
  1016. p1:=gentypenode(pd,nil);
  1017. { here we must use typenodetype explicitly !! PM
  1018. p1^.resulttype:=pd; }
  1019. pd:=voiddef;
  1020. end
  1021. else
  1022. Message(parser_e_no_type_not_allowed_here);
  1023. end;
  1024. end;
  1025. end;
  1026. end;
  1027. end;
  1028. enumsym : begin
  1029. p1:=genenumnode(penumsym(srsym));
  1030. pd:=p1^.resulttype;
  1031. end;
  1032. constsym : begin
  1033. case pconstsym(srsym)^.consttype of
  1034. constint :
  1035. p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
  1036. conststring :
  1037. begin
  1038. len:=pconstsym(srsym)^.len;
  1039. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  1040. len:=255;
  1041. getmem(pc,len+1);
  1042. move(pchar(pconstsym(srsym)^.value)^,pc^,len);
  1043. pc[len]:=#0;
  1044. p1:=genpcharconstnode(pc,len);
  1045. end;
  1046. constchar :
  1047. p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
  1048. constreal :
  1049. p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^,bestrealdef^);
  1050. constbool :
  1051. p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
  1052. constset :
  1053. p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
  1054. psetdef(pconstsym(srsym)^.definition));
  1055. constord :
  1056. p1:=genordinalconstnode(pconstsym(srsym)^.value,
  1057. pconstsym(srsym)^.definition);
  1058. constnil :
  1059. p1:=genzeronode(niln);
  1060. constresourcestring:
  1061. begin
  1062. p1:=genloadnode(pvarsym(srsym),srsymtable);
  1063. p1^.resulttype:=cansistringdef;
  1064. end;
  1065. end;
  1066. pd:=p1^.resulttype;
  1067. end;
  1068. procsym : begin
  1069. { are we in a class method ? }
  1070. possible_error:=(srsymtable^.symtabletype=objectsymtable) and
  1071. assigned(aktprocsym) and
  1072. ((aktprocsym^.definition^.options and poclassmethod)<>0);
  1073. p1:=gencallnode(pprocsym(srsym),srsymtable);
  1074. p1^.unit_specific:=unit_specific;
  1075. do_proc_call(getaddr or
  1076. (getprocvar and
  1077. (m_tp_procvar in aktmodeswitches) and
  1078. proc_to_procvar_equal(pprocsym(srsym)^.definition,getprocvardef)),
  1079. again,p1,pd);
  1080. if possible_error and
  1081. ((p1^.procdefinition^.options and poclassmethod)=0) then
  1082. Message(parser_e_only_class_methods);
  1083. end;
  1084. propertysym : begin
  1085. { access to property in a method }
  1086. { are we in a class method ? }
  1087. if (srsymtable^.symtabletype=objectsymtable) and
  1088. assigned(aktprocsym) and
  1089. ((aktprocsym^.definition^.options and poclassmethod)<>0) then
  1090. Message(parser_e_only_class_methods);
  1091. { no method pointer }
  1092. p1:=nil;
  1093. handle_propertysym(srsym,srsymtable,p1,pd);
  1094. end;
  1095. errorsym : begin
  1096. p1:=genzeronode(errorn);
  1097. p1^.resulttype:=generrordef;
  1098. pd:=generrordef;
  1099. if token=LKLAMMER then
  1100. begin
  1101. consume(LKLAMMER);
  1102. parse_paras(false,false);
  1103. consume(RKLAMMER);
  1104. end;
  1105. end;
  1106. else
  1107. begin
  1108. p1:=genzeronode(errorn);
  1109. pd:=generrordef;
  1110. Message(cg_e_illegal_expression);
  1111. end;
  1112. end; { end case }
  1113. end;
  1114. end;
  1115. end;
  1116. end;
  1117. {---------------------------------------------
  1118. Factor_Read_Set
  1119. ---------------------------------------------}
  1120. { Read a set between [] }
  1121. function factor_read_set:ptree;
  1122. var
  1123. p1,
  1124. lastp,
  1125. buildp : ptree;
  1126. begin
  1127. buildp:=nil;
  1128. { be sure that a least one arrayconstructn is used, also for an
  1129. empty [] }
  1130. if token=RECKKLAMMER then
  1131. buildp:=gennode(arrayconstructn,nil,buildp)
  1132. else
  1133. begin
  1134. while true do
  1135. begin
  1136. p1:=comp_expr(true);
  1137. if token=POINTPOINT then
  1138. begin
  1139. consume(POINTPOINT);
  1140. p2:=comp_expr(true);
  1141. p1:=gennode(arrayconstructrangen,p1,p2);
  1142. end;
  1143. { insert at the end of the tree, to get the correct order }
  1144. if not assigned(buildp) then
  1145. begin
  1146. buildp:=gennode(arrayconstructn,p1,nil);
  1147. lastp:=buildp;
  1148. end
  1149. else
  1150. begin
  1151. lastp^.right:=gennode(arrayconstructn,p1,nil);
  1152. lastp:=lastp^.right;
  1153. end;
  1154. { there could be more elements }
  1155. if token=COMMA then
  1156. consume(COMMA)
  1157. else
  1158. break;
  1159. end;
  1160. end;
  1161. factor_read_set:=buildp;
  1162. end;
  1163. {---------------------------------------------
  1164. Helpers
  1165. ---------------------------------------------}
  1166. procedure check_tokenpos;
  1167. begin
  1168. if (p1<>oldp1) then
  1169. begin
  1170. if assigned(p1) then
  1171. set_tree_filepos(p1,filepos);
  1172. oldp1:=p1;
  1173. filepos:=tokenpos;
  1174. end;
  1175. end;
  1176. {---------------------------------------------
  1177. PostFixOperators
  1178. ---------------------------------------------}
  1179. procedure postfixoperators;
  1180. var
  1181. store_static : boolean;
  1182. { p1 and p2 must contain valid value_str }
  1183. begin
  1184. check_tokenpos;
  1185. while again do
  1186. begin
  1187. { prevent crashes with unknown types }
  1188. if not assigned(pd) then
  1189. begin
  1190. { try to recover }
  1191. repeat
  1192. case token of
  1193. CARET:
  1194. consume(CARET);
  1195. POINT:
  1196. begin
  1197. consume(POINT);
  1198. consume(ID);
  1199. end;
  1200. LECKKLAMMER:
  1201. begin
  1202. repeat
  1203. consume(token);
  1204. until token in [RECKKLAMMER,SEMICOLON];
  1205. end;
  1206. else
  1207. break;
  1208. end;
  1209. until false;
  1210. exit;
  1211. end;
  1212. { handle token }
  1213. case token of
  1214. CARET:
  1215. begin
  1216. consume(CARET);
  1217. if (pd^.deftype<>pointerdef) then
  1218. begin
  1219. { ^ as binary operator is a problem!!!! (FK) }
  1220. again:=false;
  1221. Message(cg_e_invalid_qualifier);
  1222. disposetree(p1);
  1223. p1:=genzeronode(errorn);
  1224. end
  1225. else
  1226. begin
  1227. p1:=gensinglenode(derefn,p1);
  1228. pd:=ppointerdef(pd)^.definition;
  1229. end;
  1230. end;
  1231. LECKKLAMMER:
  1232. begin
  1233. if (pd^.deftype=objectdef) and pobjectdef(pd)^.isclass then
  1234. begin
  1235. { default property }
  1236. propsym:=search_default_property(pobjectdef(pd));
  1237. if not(assigned(propsym)) then
  1238. begin
  1239. disposetree(p1);
  1240. p1:=genzeronode(errorn);
  1241. again:=false;
  1242. message(parser_e_no_default_property_available);
  1243. end
  1244. else
  1245. handle_propertysym(propsym,propsym^.owner,p1,pd);
  1246. end
  1247. else
  1248. begin
  1249. consume(LECKKLAMMER);
  1250. repeat
  1251. case pd^.deftype of
  1252. pointerdef:
  1253. begin
  1254. p2:=comp_expr(true);
  1255. p1:=gennode(vecn,p1,p2);
  1256. pd:=ppointerdef(pd)^.definition;
  1257. end;
  1258. stringdef : begin
  1259. p2:=comp_expr(true);
  1260. p1:=gennode(vecn,p1,p2);
  1261. pd:=cchardef
  1262. end;
  1263. arraydef : begin
  1264. p2:=comp_expr(true);
  1265. { support SEG:OFS for go32v2 Mem[] }
  1266. if (target_info.target=target_i386_go32v2) and
  1267. (p1^.treetype=loadn) and
  1268. assigned(p1^.symtableentry) and
  1269. assigned(p1^.symtableentry^.owner^.name) and
  1270. (p1^.symtableentry^.owner^.name^='SYSTEM') and
  1271. ((p1^.symtableentry^.name='MEM') or
  1272. (p1^.symtableentry^.name='MEMW') or
  1273. (p1^.symtableentry^.name='MEML')) then
  1274. begin
  1275. if (token=COLON) then
  1276. begin
  1277. consume(COLON);
  1278. p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
  1279. p2:=comp_expr(true);
  1280. p2:=gennode(addn,p2,p3);
  1281. p1:=gennode(vecn,p1,p2);
  1282. p1^.memseg:=true;
  1283. p1^.memindex:=true;
  1284. end
  1285. else
  1286. begin
  1287. p1:=gennode(vecn,p1,p2);
  1288. p1^.memindex:=true;
  1289. end;
  1290. end
  1291. else
  1292. p1:=gennode(vecn,p1,p2);
  1293. pd:=parraydef(pd)^.definition;
  1294. end;
  1295. else
  1296. begin
  1297. Message(cg_e_invalid_qualifier);
  1298. disposetree(p1);
  1299. p1:=genzeronode(errorn);
  1300. again:=false;
  1301. end;
  1302. end;
  1303. if token=COMMA then
  1304. consume(COMMA)
  1305. else
  1306. break;
  1307. until false;
  1308. consume(RECKKLAMMER);
  1309. end;
  1310. end;
  1311. POINT : begin
  1312. consume(POINT);
  1313. if (pd^.deftype=pointerdef) and
  1314. (m_autoderef in aktmodeswitches) then
  1315. begin
  1316. p1:=gensinglenode(derefn,p1);
  1317. pd:=ppointerdef(pd)^.definition;
  1318. end;
  1319. case pd^.deftype of
  1320. recorddef:
  1321. begin
  1322. sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
  1323. if sym=nil then
  1324. begin
  1325. Message1(sym_e_illegal_field,pattern);
  1326. disposetree(p1);
  1327. p1:=genzeronode(errorn);
  1328. end
  1329. else
  1330. begin
  1331. p1:=gensubscriptnode(sym,p1);
  1332. pd:=sym^.definition;
  1333. end;
  1334. consume(ID);
  1335. end;
  1336. classrefdef:
  1337. begin
  1338. classh:=pobjectdef(pclassrefdef(pd)^.definition);
  1339. sym:=nil;
  1340. while assigned(classh) do
  1341. begin
  1342. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1343. srsymtable:=classh^.publicsyms;
  1344. if assigned(sym) then
  1345. break;
  1346. classh:=classh^.childof;
  1347. end;
  1348. consume(ID);
  1349. do_member_read(getaddr,sym,p1,pd,again);
  1350. end;
  1351. objectdef:
  1352. begin
  1353. classh:=pobjectdef(pd);
  1354. sym:=nil;
  1355. store_static:=allow_only_static;
  1356. allow_only_static:=false;
  1357. while assigned(classh) do
  1358. begin
  1359. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1360. srsymtable:=classh^.publicsyms;
  1361. if assigned(sym) then
  1362. break;
  1363. classh:=classh^.childof;
  1364. end;
  1365. allow_only_static:=store_static;
  1366. consume(ID);
  1367. do_member_read(getaddr,sym,p1,pd,again);
  1368. end;
  1369. pointerdef:
  1370. begin
  1371. Message(cg_e_invalid_qualifier);
  1372. if ppointerdef(pd)^.definition^.deftype in [recorddef,objectdef,classrefdef] then
  1373. Message(parser_h_maybe_deref_caret_missing);
  1374. end;
  1375. else
  1376. begin
  1377. Message(cg_e_invalid_qualifier);
  1378. disposetree(p1);
  1379. p1:=genzeronode(errorn);
  1380. end;
  1381. end;
  1382. end;
  1383. else
  1384. begin
  1385. { is this a procedure variable ? }
  1386. if assigned(pd) then
  1387. begin
  1388. if (pd^.deftype=procvardef) then
  1389. begin
  1390. if getprocvar and is_equal(pd,getprocvardef) then
  1391. again:=false
  1392. else
  1393. if (token=LKLAMMER) or
  1394. ((pprocvardef(pd)^.para1=nil) and
  1395. (not((token in [ASSIGNMENT,UNEQUAL,EQUAL]))) and
  1396. (not afterassignment) and
  1397. (not in_args)) then
  1398. begin
  1399. { do this in a strange way }
  1400. { it's not a clean solution }
  1401. p2:=p1;
  1402. p1:=gencallnode(nil,nil);
  1403. p1^.right:=p2;
  1404. p1^.unit_specific:=unit_specific;
  1405. p1^.symtableprocentry:=pprocsym(sym);
  1406. if token=LKLAMMER then
  1407. begin
  1408. consume(LKLAMMER);
  1409. p1^.left:=parse_paras(false,false);
  1410. consume(RKLAMMER);
  1411. end;
  1412. pd:=pprocvardef(pd)^.retdef;
  1413. { proc():= is never possible }
  1414. if token=ASSIGNMENT then
  1415. begin
  1416. Message(cg_e_illegal_expression);
  1417. p1:=genzeronode(errorn);
  1418. again:=false;
  1419. end;
  1420. p1^.resulttype:=pd;
  1421. end
  1422. else
  1423. again:=false;
  1424. p1^.resulttype:=pd;
  1425. end
  1426. else
  1427. again:=false;
  1428. end
  1429. else
  1430. again:=false;
  1431. end;
  1432. end;
  1433. check_tokenpos;
  1434. end; { while again }
  1435. end;
  1436. {---------------------------------------------
  1437. Factor (Main)
  1438. ---------------------------------------------}
  1439. begin
  1440. oldp1:=nil;
  1441. p1:=nil;
  1442. filepos:=tokenpos;
  1443. if token=ID then
  1444. begin
  1445. factor_read_id;
  1446. { handle post fix operators }
  1447. postfixoperators;
  1448. end
  1449. else
  1450. case token of
  1451. _NEW : begin
  1452. consume(_NEW);
  1453. consume(LKLAMMER);
  1454. {allow_type:=true;}
  1455. p1:=factor(false);
  1456. {allow_type:=false;}
  1457. if p1^.treetype<>typen then
  1458. begin
  1459. Message(type_e_type_id_expected);
  1460. disposetree(p1);
  1461. pd:=generrordef;
  1462. end
  1463. else
  1464. pd:=p1^.typenodetype;
  1465. pd2:=pd;
  1466. if (pd^.deftype<>pointerdef) then
  1467. Message(type_e_pointer_type_expected)
  1468. else if {(ppointerdef(pd)^.definition^.deftype<>objectdef)}
  1469. token=RKLAMMER then
  1470. begin
  1471. if (ppointerdef(pd)^.definition^.deftype=objectdef) and
  1472. ((pobjectdef(ppointerdef(pd)^.definition)^.options and oo_hasvmt) <> 0) then
  1473. Message(parser_w_use_extended_syntax_for_objects);
  1474. p1:=gensinglenode(newn,nil);
  1475. p1^.resulttype:=pd2;
  1476. consume(RKLAMMER);
  1477. (*Message(parser_e_pointer_to_class_expected);
  1478. { if an error occurs, read til the end of
  1479. the new statement }
  1480. p1:=genzeronode(errorn);
  1481. l:=1;
  1482. while true do
  1483. begin
  1484. case token of
  1485. LKLAMMER : inc(l);
  1486. RKLAMMER : dec(l);
  1487. end;
  1488. consume(token);
  1489. if l=0 then
  1490. break;
  1491. end;*)
  1492. end
  1493. else
  1494. begin
  1495. disposetree(p1);
  1496. p1:=genzeronode(hnewn);
  1497. p1^.resulttype:=ppointerdef(pd)^.definition;
  1498. consume(COMMA);
  1499. afterassignment:=false;
  1500. { determines the current object defintion }
  1501. classh:=pobjectdef(ppointerdef(pd)^.definition);
  1502. { check for an abstract class }
  1503. if (classh^.options and oo_is_abstract)<>0 then
  1504. Message(sym_e_no_instance_of_abstract_object);
  1505. { search the constructor also in the symbol tables of
  1506. the parents }
  1507. { no constructor found }
  1508. sym:=nil;
  1509. while assigned(classh) do
  1510. begin
  1511. sym:=pvarsym(classh^.publicsyms^.search(pattern));
  1512. srsymtable:=classh^.publicsyms;
  1513. if assigned(sym) then
  1514. break;
  1515. classh:=classh^.childof;
  1516. end;
  1517. consume(ID);
  1518. do_member_read(false,sym,p1,pd,again);
  1519. if (p1^.treetype<>calln) or
  1520. (assigned(p1^.procdefinition) and
  1521. ((p1^.procdefinition^.options and poconstructor)=0)) then
  1522. Message(parser_e_expr_have_to_be_constructor_call);
  1523. p1:=gensinglenode(newn,p1);
  1524. { set the resulttype }
  1525. p1^.resulttype:=pd2;
  1526. consume(RKLAMMER);
  1527. end;
  1528. end;
  1529. _SELF : begin
  1530. again:=true;
  1531. consume(_SELF);
  1532. if not assigned(procinfo._class) then
  1533. begin
  1534. p1:=genzeronode(errorn);
  1535. pd:=generrordef;
  1536. again:=false;
  1537. Message(parser_e_self_not_in_method);
  1538. end
  1539. else
  1540. begin
  1541. if (aktprocsym^.definition^.options and poclassmethod)<>0 then
  1542. begin
  1543. { self in class methods is a class reference type }
  1544. pd:=new(pclassrefdef,init(procinfo._class));
  1545. p1:=genselfnode(pd);
  1546. p1^.resulttype:=pd;
  1547. end
  1548. else
  1549. begin
  1550. p1:=genselfnode(procinfo._class);
  1551. p1^.resulttype:=procinfo._class;
  1552. end;
  1553. pd:=p1^.resulttype;
  1554. postfixoperators;
  1555. end;
  1556. end;
  1557. _INHERITED : begin
  1558. again:=true;
  1559. consume(_INHERITED);
  1560. if assigned(procinfo._class) then
  1561. begin
  1562. classh:=procinfo._class^.childof;
  1563. while assigned(classh) do
  1564. begin
  1565. srsymtable:=pobjectdef(classh)^.publicsyms;
  1566. sym:=pvarsym(srsymtable^.search(pattern));
  1567. if assigned(sym) then
  1568. begin
  1569. p1:=genzeronode(typen);
  1570. p1^.resulttype:=classh;
  1571. pd:=p1^.resulttype;
  1572. consume(ID);
  1573. do_member_read(false,sym,p1,pd,again);
  1574. break;
  1575. end;
  1576. classh:=classh^.childof;
  1577. end;
  1578. if classh=nil then
  1579. begin
  1580. Message1(sym_e_id_no_member,pattern);
  1581. again:=false;
  1582. pd:=generrordef;
  1583. p1:=genzeronode(errorn);
  1584. end;
  1585. end
  1586. else
  1587. begin
  1588. Message(parser_e_generic_methods_only_in_methods);
  1589. again:=false;
  1590. pd:=generrordef;
  1591. p1:=genzeronode(errorn);
  1592. end;
  1593. postfixoperators;
  1594. end;
  1595. INTCONST : begin
  1596. valint(pattern,l,code);
  1597. if code<>0 then
  1598. begin
  1599. val(pattern,d,code);
  1600. if code<>0 then
  1601. begin
  1602. Message(cg_e_invalid_integer);
  1603. consume(INTCONST);
  1604. l:=1;
  1605. p1:=genordinalconstnode(l,s32bitdef);
  1606. end
  1607. else
  1608. begin
  1609. consume(INTCONST);
  1610. p1:=genrealconstnode(d,bestrealdef^);
  1611. end;
  1612. end
  1613. else
  1614. begin
  1615. consume(INTCONST);
  1616. p1:=genordinalconstnode(l,s32bitdef);
  1617. end;
  1618. end;
  1619. REALNUMBER : begin
  1620. val(pattern,d,code);
  1621. if code<>0 then
  1622. begin
  1623. Message(parser_e_error_in_real);
  1624. d:=1.0;
  1625. end;
  1626. consume(REALNUMBER);
  1627. p1:=genrealconstnode(d,bestrealdef^);
  1628. end;
  1629. _STRING : begin
  1630. pd:=stringtype;
  1631. { STRING can be also a type cast }
  1632. if token=LKLAMMER then
  1633. begin
  1634. consume(LKLAMMER);
  1635. p1:=comp_expr(true);
  1636. consume(RKLAMMER);
  1637. p1:=gentypeconvnode(p1,pd);
  1638. p1^.explizit:=true;
  1639. { handle postfix operators here e.g. string(a)[10] }
  1640. again:=true;
  1641. postfixoperators;
  1642. end
  1643. else
  1644. p1:=gentypenode(pd,nil);
  1645. end;
  1646. _FILE : begin
  1647. pd:=cfiledef;
  1648. consume(_FILE);
  1649. { FILE can be also a type cast }
  1650. if token=LKLAMMER then
  1651. begin
  1652. consume(LKLAMMER);
  1653. p1:=comp_expr(true);
  1654. consume(RKLAMMER);
  1655. p1:=gentypeconvnode(p1,pd);
  1656. p1^.explizit:=true;
  1657. { handle postfix operators here e.g. string(a)[10] }
  1658. again:=true;
  1659. postfixoperators;
  1660. end
  1661. else
  1662. p1:=gentypenode(pd,nil);
  1663. end;
  1664. CSTRING : begin
  1665. p1:=genstringconstnode(pattern);
  1666. consume(CSTRING);
  1667. end;
  1668. CCHAR : begin
  1669. p1:=genordinalconstnode(ord(pattern[1]),cchardef);
  1670. consume(CCHAR);
  1671. end;
  1672. KLAMMERAFFE : begin
  1673. consume(KLAMMERAFFE);
  1674. got_addrn:=true;
  1675. p1:=factor(true);
  1676. got_addrn:=false;
  1677. p1:=gensinglenode(addrn,p1);
  1678. end;
  1679. LKLAMMER : begin
  1680. consume(LKLAMMER);
  1681. p1:=comp_expr(true);
  1682. consume(RKLAMMER);
  1683. { it's not a good solution }
  1684. { but (a+b)^ makes some problems }
  1685. if token in [CARET,POINT,LECKKLAMMER] then
  1686. begin
  1687. { we need the resulttype }
  1688. { of the expression in pd }
  1689. do_firstpass(p1);
  1690. pd:=p1^.resulttype;
  1691. again:=true;
  1692. postfixoperators;
  1693. end;
  1694. end;
  1695. LECKKLAMMER : begin
  1696. consume(LECKKLAMMER);
  1697. p1:=factor_read_set;
  1698. consume(RECKKLAMMER);
  1699. end;
  1700. PLUS : begin
  1701. consume(PLUS);
  1702. p1:=factor(false);
  1703. end;
  1704. MINUS : begin
  1705. consume(MINUS);
  1706. p1:=factor(false);
  1707. p1:=gensinglenode(umminusn,p1);
  1708. end;
  1709. _NOT : begin
  1710. consume(_NOT);
  1711. p1:=factor(false);
  1712. p1:=gensinglenode(notn,p1);
  1713. end;
  1714. _TRUE : begin
  1715. consume(_TRUE);
  1716. p1:=genordinalconstnode(1,booldef);
  1717. end;
  1718. _FALSE : begin
  1719. consume(_FALSE);
  1720. p1:=genordinalconstnode(0,booldef);
  1721. end;
  1722. _NIL : begin
  1723. consume(_NIL);
  1724. p1:=genzeronode(niln);
  1725. end;
  1726. else
  1727. begin
  1728. p1:=genzeronode(errorn);
  1729. consume(token);
  1730. Message(cg_e_illegal_expression);
  1731. end;
  1732. end;
  1733. { generate error node if no node is created }
  1734. if not assigned(p1) then
  1735. p1:=genzeronode(errorn);
  1736. { tp7 procvar handling, but not if the next token
  1737. will be a := }
  1738. if (m_tp_procvar in aktmodeswitches) and
  1739. (token<>ASSIGNMENT) then
  1740. check_tp_procvar(p1);
  1741. factor:=p1;
  1742. check_tokenpos;
  1743. end;
  1744. {****************************************************************************
  1745. Sub_Expr
  1746. ****************************************************************************}
  1747. type
  1748. Toperator_precedence=(opcompare,opaddition,opmultiply);
  1749. Ttok2nodeRec=record
  1750. tok : ttoken;
  1751. nod : ttreetyp;
  1752. end;
  1753. const
  1754. tok2nodes=23;
  1755. tok2node:array[1..tok2nodes] of ttok2noderec=(
  1756. (tok:PLUS ;nod:addn),
  1757. (tok:MINUS ;nod:subn),
  1758. (tok:STAR ;nod:muln),
  1759. (tok:SLASH ;nod:slashn),
  1760. (tok:EQUAL ;nod:equaln),
  1761. (tok:GT ;nod:gtn),
  1762. (tok:LT ;nod:ltn),
  1763. (tok:GTE ;nod:gten),
  1764. (tok:LTE ;nod:lten),
  1765. (tok:SYMDIF ;nod:symdifn),
  1766. (tok:STARSTAR;nod:starstarn),
  1767. (tok:CARET ;nod:caretn),
  1768. (tok:UNEQUAL ;nod:unequaln),
  1769. (tok:_AS ;nod:asn),
  1770. (tok:_IN ;nod:inn),
  1771. (tok:_IS ;nod:isn),
  1772. (tok:_OR ;nod:orn),
  1773. (tok:_AND ;nod:andn),
  1774. (tok:_DIV ;nod:divn),
  1775. (tok:_MOD ;nod:modn),
  1776. (tok:_SHL ;nod:shln),
  1777. (tok:_SHR ;nod:shrn),
  1778. (tok:_XOR ;nod:xorn)
  1779. );
  1780. operator_levels:array[Toperator_precedence] of set of Ttoken=
  1781. ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
  1782. [PLUS,MINUS,_OR,_XOR],
  1783. [CARET,SYMDIF,STARSTAR,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
  1784. function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;
  1785. {Reads a subexpression while the operators are of the current precedence
  1786. level, or any higher level. Replaces the old term, simpl_expr and
  1787. simpl2_expr.}
  1788. var
  1789. low,high,mid : longint;
  1790. p1,p2 : Ptree;
  1791. oldt : Ttoken;
  1792. filepos : tfileposinfo;
  1793. begin
  1794. if pred_level=opmultiply then
  1795. p1:=factor(false)
  1796. else
  1797. p1:=sub_expr(succ(pred_level),true);
  1798. repeat
  1799. if (token in operator_levels[pred_level]) and
  1800. ((token<>EQUAL) or accept_equal) then
  1801. begin
  1802. oldt:=token;
  1803. filepos:=tokenpos;
  1804. consume(token);
  1805. if pred_level=opmultiply then
  1806. p2:=factor(false)
  1807. else
  1808. p2:=sub_expr(succ(pred_level),true);
  1809. low:=1;
  1810. high:=tok2nodes;
  1811. while (low<high) do
  1812. begin
  1813. mid:=(low+high+1) shr 1;
  1814. if oldt<tok2node[mid].tok then
  1815. high:=mid-1
  1816. else
  1817. low:=mid;
  1818. end;
  1819. if tok2node[high].tok=oldt then
  1820. p1:=gennode(tok2node[high].nod,p1,p2)
  1821. else
  1822. p1:=gennode(nothingn,p1,p2);
  1823. set_tree_filepos(p1,filepos);
  1824. end
  1825. else
  1826. break;
  1827. until false;
  1828. sub_expr:=p1;
  1829. end;
  1830. function comp_expr(accept_equal : boolean):Ptree;
  1831. var
  1832. oldafterassignment : boolean;
  1833. p1 : ptree;
  1834. begin
  1835. oldafterassignment:=afterassignment;
  1836. afterassignment:=true;
  1837. p1:=sub_expr(opcompare,accept_equal);
  1838. afterassignment:=oldafterassignment;
  1839. comp_expr:=p1;
  1840. end;
  1841. function expr : ptree;
  1842. var
  1843. p1,p2 : ptree;
  1844. oldafterassignment : boolean;
  1845. oldp1 : ptree;
  1846. filepos : tfileposinfo;
  1847. begin
  1848. oldafterassignment:=afterassignment;
  1849. p1:=sub_expr(opcompare,true);
  1850. filepos:=tokenpos;
  1851. if (m_tp_procvar in aktmodeswitches) and
  1852. (token<>ASSIGNMENT) then
  1853. check_tp_procvar(p1);
  1854. if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
  1855. afterassignment:=true;
  1856. oldp1:=p1;
  1857. case token of
  1858. POINTPOINT : begin
  1859. consume(POINTPOINT);
  1860. p2:=sub_expr(opcompare,true);
  1861. p1:=gennode(rangen,p1,p2);
  1862. end;
  1863. ASSIGNMENT : begin
  1864. consume(ASSIGNMENT);
  1865. { avoid a firstpass of a procedure if
  1866. it must be assigned to a procvar }
  1867. { should be recursive for a:=b:=c !!! }
  1868. if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
  1869. begin
  1870. getprocvar:=true;
  1871. getprocvardef:=pprocvardef(p1^.resulttype);
  1872. end;
  1873. p2:=sub_expr(opcompare,true);
  1874. if getprocvar then
  1875. begin
  1876. if (p2^.treetype=calln) then
  1877. handle_procvar(getprocvardef,p2)
  1878. else
  1879. { also allow p:= proc(t); !! (PM) }
  1880. if (p2^.treetype=typeconvn) and
  1881. (p2^.left^.treetype=calln) then
  1882. handle_procvar(getprocvardef,p2^.left);
  1883. end;
  1884. getprocvar:=false;
  1885. p1:=gennode(assignn,p1,p2);
  1886. end;
  1887. { this is the code for C like assignements }
  1888. { from an improvement of Peter Schaefer }
  1889. _PLUSASN : begin
  1890. consume(_PLUSASN );
  1891. p2:=sub_expr(opcompare,true);
  1892. p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
  1893. { was first
  1894. p1:=gennode(assignn,p1,gennode(addn,p1,p2));
  1895. but disposetree assumes that we have a real
  1896. *** tree *** }
  1897. end;
  1898. _MINUSASN : begin
  1899. consume(_MINUSASN );
  1900. p2:=sub_expr(opcompare,true);
  1901. p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
  1902. end;
  1903. _STARASN : begin
  1904. consume(_STARASN );
  1905. p2:=sub_expr(opcompare,true);
  1906. p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
  1907. end;
  1908. _SLASHASN : begin
  1909. consume(_SLASHASN );
  1910. p2:=sub_expr(opcompare,true);
  1911. p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
  1912. end;
  1913. end;
  1914. afterassignment:=oldafterassignment;
  1915. if p1<>oldp1 then
  1916. set_tree_filepos(p1,filepos);
  1917. expr:=p1;
  1918. end;
  1919. function get_intconst:longint;
  1920. {Reads an expression, tries to evalute it and check if it is an integer
  1921. constant. Then the constant is returned.}
  1922. var
  1923. p:Ptree;
  1924. begin
  1925. p:=comp_expr(true);
  1926. do_firstpass(p);
  1927. if not codegenerror then
  1928. begin
  1929. if (p^.treetype<>ordconstn) and
  1930. (p^.resulttype^.deftype=orddef) and
  1931. not(Porddef(p^.resulttype)^.typ in [uvoid,uchar,bool8bit,bool16bit,bool32bit]) then
  1932. Message(cg_e_illegal_expression)
  1933. else
  1934. get_intconst:=p^.value;
  1935. end;
  1936. disposetree(p);
  1937. end;
  1938. function get_stringconst:string;
  1939. {Reads an expression, tries to evaluate it and checks if it is a string
  1940. constant. Then the constant is returned.}
  1941. var
  1942. p:Ptree;
  1943. begin
  1944. get_stringconst:='';
  1945. p:=comp_expr(true);
  1946. do_firstpass(p);
  1947. if p^.treetype<>stringconstn then
  1948. begin
  1949. if (p^.treetype=ordconstn) and is_char(p^.resulttype) then
  1950. get_stringconst:=char(p^.value)
  1951. else
  1952. Message(cg_e_illegal_expression);
  1953. end
  1954. else
  1955. get_stringconst:=strpas(p^.value_str);
  1956. disposetree(p);
  1957. end;
  1958. end.
  1959. {
  1960. $Log$
  1961. Revision 1.127 1999-08-01 18:28:13 florian
  1962. * modifications for the new code generator
  1963. Revision 1.126 1999/07/30 12:28:40 peter
  1964. * fixed crash with unknown id and colon parameter in write
  1965. Revision 1.125 1999/07/27 23:42:14 peter
  1966. * indirect type referencing is now allowed
  1967. Revision 1.124 1999/07/23 21:31:42 peter
  1968. * fixed crash with resourcestring
  1969. Revision 1.123 1999/07/23 11:37:46 peter
  1970. * error for illegal type reference, instead of 10998
  1971. Revision 1.122 1999/07/22 09:37:52 florian
  1972. + resourcestring implemented
  1973. + start of longstring support
  1974. Revision 1.121 1999/07/16 10:04:35 peter
  1975. * merged
  1976. Revision 1.120 1999/07/06 22:38:11 florian
  1977. * another fix for TP/Delphi styled procedure variables
  1978. Revision 1.119 1999/07/05 20:13:16 peter
  1979. * removed temp defines
  1980. Revision 1.118 1999/07/01 21:33:57 peter
  1981. * merged
  1982. Revision 1.117 1999/06/30 15:43:20 florian
  1983. * two bugs regarding method variables fixed
  1984. - if you take in a method the address of another method
  1985. don't need self anymore
  1986. - if the class pointer was in a register, wrong code for a method
  1987. variable load was generated
  1988. Revision 1.116 1999/06/26 00:24:53 pierre
  1989. * mereg from fixes-0_99_12 branch
  1990. Revision 1.112.2.8 1999/07/16 09:54:57 peter
  1991. * @procvar support in tp7 mode works again
  1992. Revision 1.112.2.7 1999/07/07 07:53:10 michael
  1993. + Merged patches from florian
  1994. Revision 1.112.2.6 1999/07/01 21:31:59 peter
  1995. * procvar fixes again
  1996. Revision 1.112.2.5 1999/07/01 15:17:17 peter
  1997. * methoidpointer fixes from florian
  1998. Revision 1.112.2.4 1999/06/26 00:22:30 pierre
  1999. * wrong warnings in -So mode suppressed
  2000. Revision 1.112.2.3 1999/06/17 12:51:44 pierre
  2001. * changed is_assignment_overloaded into
  2002. function assignment_overloaded : pprocdef
  2003. to allow overloading of assignment with only different result type
  2004. Revision 1.112.2.2 1999/06/15 18:54:52 peter
  2005. * more procvar fixes
  2006. Revision 1.112.2.1 1999/06/13 22:38:09 peter
  2007. * tp_procvar check for loading of procvars when getaddr=false
  2008. Revision 1.112 1999/06/02 22:44:11 pierre
  2009. * previous wrong log corrected
  2010. Revision 1.111 1999/06/02 22:25:43 pierre
  2011. * changed $ifdef FPC @ into $ifndef TP
  2012. * changes for correct procvar handling under tp mode
  2013. Revision 1.110 1999/06/01 19:27:55 peter
  2014. * better checks for procvar and methodpointer
  2015. Revision 1.109 1999/05/27 19:44:46 peter
  2016. * removed oldasm
  2017. * plabel -> pasmlabel
  2018. * -a switches to source writing automaticly
  2019. * assembler readers OOPed
  2020. * asmsymbol automaticly external
  2021. * jumptables and other label fixes for asm readers
  2022. Revision 1.108 1999/05/18 14:15:54 peter
  2023. * containsself fixes
  2024. * checktypes()
  2025. Revision 1.107 1999/05/18 09:52:18 peter
  2026. * procedure of object and addrn fixes
  2027. Revision 1.106 1999/05/16 17:06:31 peter
  2028. * remove firstcallparan which looks obsolete
  2029. Revision 1.105 1999/05/12 22:36:09 florian
  2030. * override isn't allowed in objects!
  2031. Revision 1.104 1999/05/07 10:35:23 florian
  2032. * first fix for a problem with method pointer properties, still doesn't work
  2033. with WITH
  2034. Revision 1.103 1999/05/06 21:40:16 peter
  2035. * fixed crash
  2036. Revision 1.101 1999/05/06 09:05:21 peter
  2037. * generic write_float and str_float
  2038. * fixed constant float conversions
  2039. Revision 1.100 1999/05/04 21:44:57 florian
  2040. * changes to compile it with Delphi 4.0
  2041. Revision 1.99 1999/05/01 13:24:31 peter
  2042. * merged nasm compiler
  2043. * old asm moved to oldasm/
  2044. Revision 1.98 1999/04/26 18:29:56 peter
  2045. * farpointerdef moved into pointerdef.is_far
  2046. Revision 1.97 1999/04/19 09:27:48 peter
  2047. * removed my property fix
  2048. Revision 1.96 1999/04/19 09:13:47 peter
  2049. * class property without write support
  2050. Revision 1.95 1999/04/19 06:10:08 florian
  2051. * property problem fixed: a propertysym is only a write
  2052. access if it is followed by a assignment token
  2053. Revision 1.94 1999/04/17 13:12:17 peter
  2054. * addr() internal
  2055. Revision 1.93 1999/04/15 09:00:08 peter
  2056. * fixed property write
  2057. Revision 1.92 1999/04/08 20:59:43 florian
  2058. * fixed problem with default properties which are a class
  2059. * case bug (from the mailing list with -O2) fixed, the
  2060. distance of the case labels can be greater than the positive
  2061. range of a longint => it is now a dword for fpc
  2062. Revision 1.91 1999/04/06 11:21:56 peter
  2063. * more use of ttoken
  2064. Revision 1.90 1999/03/31 13:55:12 peter
  2065. * assembler inlining working for ag386bin
  2066. Revision 1.89 1999/03/26 00:05:36 peter
  2067. * released valintern
  2068. + deffile is now removed when compiling is finished
  2069. * ^( compiles now correct
  2070. + static directive
  2071. * shrd fixed
  2072. Revision 1.88 1999/03/24 23:17:15 peter
  2073. * fixed bugs 212,222,225,227,229,231,233
  2074. Revision 1.87 1999/03/16 17:52:52 jonas
  2075. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  2076. * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  2077. * in cgai386: also small fixes to emitrangecheck
  2078. Revision 1.86 1999/03/04 13:55:44 pierre
  2079. * some m68k fixes (still not compilable !)
  2080. * new(tobj) does not give warning if tobj has no VMT !
  2081. Revision 1.85 1999/02/22 15:09:39 florian
  2082. * behaviaor of PROTECTED and PRIVATE fixed, works now like TP/Delphi
  2083. Revision 1.84 1999/02/22 02:15:26 peter
  2084. * updates for ag386bin
  2085. Revision 1.83 1999/02/11 09:46:25 pierre
  2086. * fix for normal method calls inside static methods :
  2087. WARNING there were both parser and codegen errors !!
  2088. added static_call boolean to calln tree
  2089. Revision 1.82 1999/01/28 14:06:47 florian
  2090. * small fix for method pointers
  2091. * found the annoying strpas bug, mainly nested call to type cast which
  2092. use ansistrings crash
  2093. Revision 1.81 1999/01/27 00:13:55 florian
  2094. * "procedure of object"-stuff fixed
  2095. Revision 1.80 1999/01/21 16:41:01 pierre
  2096. * fix for constructor inside with statements
  2097. Revision 1.79 1998/12/30 22:15:48 peter
  2098. + farpointer type
  2099. * absolutesym now also stores if its far
  2100. Revision 1.78 1998/12/11 00:03:32 peter
  2101. + globtype,tokens,version unit splitted from globals
  2102. Revision 1.77 1998/12/04 10:18:09 florian
  2103. * some stuff for procedures of object added
  2104. * bug with overridden virtual constructors fixed (reported by Italo Gomes)
  2105. Revision 1.76 1998/11/27 14:50:40 peter
  2106. + open strings, $P switch support
  2107. Revision 1.75 1998/11/25 19:12:51 pierre
  2108. * var:=new(pointer_type) support added
  2109. Revision 1.74 1998/11/13 10:18:11 peter
  2110. + nil constants
  2111. Revision 1.73 1998/11/05 12:02:52 peter
  2112. * released useansistring
  2113. * removed -Sv, its now available in fpc modes
  2114. Revision 1.72 1998/11/04 10:11:41 peter
  2115. * ansistring fixes
  2116. Revision 1.71 1998/10/22 23:57:29 peter
  2117. * fixed filedef for typenodetype
  2118. Revision 1.70 1998/10/21 15:12:54 pierre
  2119. * bug fix for IOCHECK inside a procedure with iocheck modifier
  2120. * removed the GPF for unexistant overloading
  2121. (firstcall was called with procedinition=nil !)
  2122. * changed typen to what Florian proposed
  2123. gentypenode(p : pdef) sets the typenodetype field
  2124. and resulttype is only set if inside bt_type block !
  2125. Revision 1.69 1998/10/20 15:10:19 pierre
  2126. * type ptree only allowed inside expression
  2127. if following sizeof typeof low high or as first arg of new !!
  2128. Revision 1.68 1998/10/20 11:15:44 pierre
  2129. * calling of private method allowed inside child object method
  2130. Revision 1.67 1998/10/19 08:54:57 pierre
  2131. * wrong stabs info corrected once again !!
  2132. + variable vmt offset with vmt field only if required
  2133. implemented now !!!
  2134. Revision 1.66 1998/10/15 15:13:28 pierre
  2135. + added oo_hasconstructor and oo_hasdestructor
  2136. for objects options
  2137. Revision 1.65 1998/10/13 13:10:24 peter
  2138. * new style for m68k/i386 infos and enums
  2139. Revision 1.64 1998/10/12 12:20:55 pierre
  2140. + added tai_const_symbol_offset
  2141. for r : pointer = @var.field;
  2142. * better message for different arg names on implementation
  2143. of function
  2144. Revision 1.63 1998/10/12 10:28:30 florian
  2145. + auto dereferencing of pointers to structured types in delphi mode
  2146. Revision 1.62 1998/10/12 10:05:41 peter
  2147. * fixed mem leak with arrayconstrutor
  2148. Revision 1.61 1998/10/05 13:57:15 peter
  2149. * crash preventions
  2150. Revision 1.60 1998/10/05 12:32:46 peter
  2151. + assert() support
  2152. Revision 1.59 1998/10/01 14:56:24 peter
  2153. * crash preventions
  2154. Revision 1.58 1998/09/30 07:40:35 florian
  2155. * better error recovering
  2156. Revision 1.57 1998/09/28 16:18:16 florian
  2157. * two fixes to get ansi strings work
  2158. Revision 1.56 1998/09/26 17:45:36 peter
  2159. + idtoken and only one token table
  2160. Revision 1.55 1998/09/24 23:49:10 peter
  2161. + aktmodeswitches
  2162. Revision 1.54 1998/09/23 15:46:39 florian
  2163. * problem with with and classes fixed
  2164. Revision 1.53 1998/09/23 09:58:54 peter
  2165. * first working array of const things
  2166. Revision 1.52 1998/09/20 09:38:45 florian
  2167. * hasharray for defs fixed
  2168. * ansistring code generation corrected (init/final, assignement)
  2169. Revision 1.51 1998/09/18 16:03:43 florian
  2170. * some changes to compile with Delphi
  2171. Revision 1.50 1998/09/17 13:41:18 pierre
  2172. sizeof(TPOINT) problem
  2173. Revision 1.49.2.1 1998/09/17 08:42:31 pierre
  2174. TPOINT sizeof fix
  2175. Revision 1.49 1998/09/09 11:50:53 pierre
  2176. * forward def are not put in record or objects
  2177. + added check for forwards also in record and objects
  2178. * dummy parasymtable for unit initialization removed from
  2179. symtable stack
  2180. Revision 1.48 1998/09/07 22:25:53 peter
  2181. * fixed str(boolean,string) which was allowed
  2182. * fixed write(' ':<int expression>) only constants where allowed :(
  2183. Revision 1.47 1998/09/07 18:46:10 peter
  2184. * update smartlinking, uses getdatalabel
  2185. * renamed ptree.value vars to value_str,value_real,value_set
  2186. Revision 1.46 1998/09/04 08:42:03 peter
  2187. * updated some error messages
  2188. Revision 1.45 1998/09/01 17:39:49 peter
  2189. + internal constant functions
  2190. Revision 1.44 1998/08/28 10:54:24 peter
  2191. * fixed smallset generation from elements, it has never worked before!
  2192. Revision 1.43 1998/08/23 16:07:24 florian
  2193. * internalerror with mod/div fixed
  2194. Revision 1.42 1998/08/21 14:08:50 pierre
  2195. + TEST_FUNCRET now default (old code removed)
  2196. works also for m68k (at least compiles)
  2197. Revision 1.41 1998/08/20 21:36:39 peter
  2198. * fixed 'with object do' bug
  2199. Revision 1.40 1998/08/20 09:26:41 pierre
  2200. + funcret setting in underproc testing
  2201. compile with _dTEST_FUNCRET
  2202. Revision 1.39 1998/08/18 16:48:48 pierre
  2203. * bug for -So proc assignment to p^rocvar fixed
  2204. Revision 1.38 1998/08/18 14:17:09 pierre
  2205. * bug about assigning the return value of a function to
  2206. a procvar fixed : warning
  2207. assigning a proc to a procvar need @ in FPC mode !!
  2208. * missing file/line info restored
  2209. Revision 1.37 1998/08/18 09:24:43 pierre
  2210. * small warning position bug fixed
  2211. * support_mmx switches splitting was missing
  2212. * rhide error and warning output corrected
  2213. Revision 1.36 1998/08/15 16:50:29 peter
  2214. * fixed proc()=expr which was not allowed anymore by my previous fix
  2215. Revision 1.35 1998/08/14 18:18:46 peter
  2216. + dynamic set contruction
  2217. * smallsets are now working (always longint size)
  2218. Revision 1.34 1998/08/13 11:00:12 peter
  2219. * fixed procedure<>procedure construct
  2220. Revision 1.33 1998/08/11 15:31:39 peter
  2221. * write extended to ppu file
  2222. * new version 0.99.7
  2223. Revision 1.32 1998/08/11 14:05:32 peter
  2224. * fixed sizeof(array of char)
  2225. Revision 1.31 1998/08/10 14:50:11 peter
  2226. + localswitches, moduleswitches, globalswitches splitting
  2227. Revision 1.30 1998/07/28 21:52:54 florian
  2228. + implementation of raise and try..finally
  2229. + some misc. exception stuff
  2230. Revision 1.29 1998/07/27 21:57:13 florian
  2231. * fix to allow tv like stream registration:
  2232. @tmenu.load doesn't work if load had parameters or if load was only
  2233. declared in an anchestor class of tmenu
  2234. Revision 1.28 1998/07/14 21:46:51 peter
  2235. * updated messages file
  2236. Revision 1.27 1998/06/25 14:04:23 peter
  2237. + internal inc/dec
  2238. Revision 1.26 1998/06/09 16:01:46 pierre
  2239. + added procedure directive parsing for procvars
  2240. (accepted are popstack cdecl and pascal)
  2241. + added C vars with the following syntax
  2242. var C calias 'true_c_name';(can be followed by external)
  2243. reason is that you must add the Cprefix
  2244. which is target dependent
  2245. Revision 1.25 1998/06/05 14:37:33 pierre
  2246. * fixes for inline for operators
  2247. * inline procedure more correctly restricted
  2248. Revision 1.24 1998/06/04 23:51:52 peter
  2249. * m68k compiles
  2250. + .def file creation moved to gendef.pas so it could also be used
  2251. for win32
  2252. Revision 1.23 1998/06/04 09:55:40 pierre
  2253. * demangled name of procsym reworked to become independant of the mangling scheme
  2254. Revision 1.22 1998/06/02 17:03:03 pierre
  2255. * with node corrected for objects
  2256. * small bugs for SUPPORT_MMX fixed
  2257. Revision 1.21 1998/05/27 19:45:05 peter
  2258. * symtable.pas splitted into includefiles
  2259. * symtable adapted for $ifdef NEWPPU
  2260. Revision 1.20 1998/05/26 07:53:59 pierre
  2261. * bug fix for empty sets (nil pd was dereferenced )
  2262. Revision 1.19 1998/05/25 17:11:43 pierre
  2263. * firstpasscount bug fixed
  2264. now all is already set correctly the first time
  2265. under EXTDEBUG try -gp to skip all other firstpasses
  2266. it works !!
  2267. * small bug fixes
  2268. - for smallsets with -dTESTSMALLSET
  2269. - some warnings removed (by correcting code !)
  2270. Revision 1.18 1998/05/23 01:21:20 peter
  2271. + aktasmmode, aktoptprocessor, aktoutputformat
  2272. + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
  2273. + $LIBNAME to set the library name where the unit will be put in
  2274. * splitted cgi386 a bit (codeseg to large for bp7)
  2275. * nasm, tasm works again. nasm moved to ag386nsm.pas
  2276. Revision 1.17 1998/05/22 12:37:03 carl
  2277. * crash bugfix (patched msanually to main branch)
  2278. Revision 1.16 1998/05/21 19:33:32 peter
  2279. + better procedure directive handling and only one table
  2280. Revision 1.15 1998/05/20 09:42:35 pierre
  2281. + UseTokenInfo now default
  2282. * unit in interface uses and implementation uses gives error now
  2283. * only one error for unknown symbol (uses lastsymknown boolean)
  2284. the problem came from the label code !
  2285. + first inlined procedures and function work
  2286. (warning there might be allowed cases were the result is still wrong !!)
  2287. * UseBrower updated gives a global list of all position of all used symbols
  2288. with switch -gb
  2289. Revision 1.14 1998/05/11 13:07:56 peter
  2290. + $ifdef NEWPPU for the new ppuformat
  2291. + $define GDB not longer required
  2292. * removed all warnings and stripped some log comments
  2293. * no findfirst/findnext anymore to remove smartlink *.o files
  2294. Revision 1.13 1998/05/06 08:38:45 pierre
  2295. * better position info with UseTokenInfo
  2296. UseTokenInfo greatly simplified
  2297. + added check for changed tree after first time firstpass
  2298. (if we could remove all the cases were it happen
  2299. we could skip all firstpass if firstpasscount > 1)
  2300. Only with ExtDebug
  2301. Revision 1.12 1998/05/05 12:05:42 florian
  2302. * problems with properties fixed
  2303. * crash fixed: i:=l when i and l are undefined, was a problem with
  2304. implementation of private/protected
  2305. Revision 1.11 1998/05/04 11:22:26 florian
  2306. * problem with DOM solved: it crashes when accessing a property in a method
  2307. Revision 1.10 1998/05/01 16:38:45 florian
  2308. * handling of private and protected fixed
  2309. + change_keywords_to_tp implemented to remove
  2310. keywords which aren't supported by tp
  2311. * break and continue are now symbols of the system unit
  2312. + widestring, longstring and ansistring type released
  2313. Revision 1.9 1998/04/29 10:33:58 pierre
  2314. + added some code for ansistring (not complete nor working yet)
  2315. * corrected operator overloading
  2316. * corrected nasm output
  2317. + started inline procedures
  2318. + added starstarn : use ** for exponentiation (^ gave problems)
  2319. + started UseTokenInfo cond to get accurate positions
  2320. Revision 1.8 1998/04/14 23:27:03 florian
  2321. + exclude/include with constant second parameter added
  2322. Revision 1.7 1998/04/09 23:02:15 florian
  2323. * small problems solved to get remake3 work
  2324. Revision 1.6 1998/04/09 22:16:35 florian
  2325. * problem with previous REGALLOC solved
  2326. * improved property support
  2327. Revision 1.5 1998/04/08 10:26:09 florian
  2328. * correct error handling of virtual constructors
  2329. * problem with new type declaration handling fixed
  2330. Revision 1.4 1998/04/07 22:45:05 florian
  2331. * bug0092, bug0115 and bug0121 fixed
  2332. + packed object/class/array
  2333. Revision 1.3 1998/04/07 13:19:46 pierre
  2334. * bugfixes for reset_gdb_info
  2335. in MEM parsing for go32v2
  2336. better external symbol creation
  2337. support for rhgdb.exe (lowercase file names)
  2338. }