pexpr.pas 95 KB

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