pexpr.pas 91 KB

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