123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054 |
- {
- Copyright (c) 1998-2002 by Florian Klaempfl
- Does parsing of expression for Free Pascal
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit pexpr;
- {$i fpcdefs.inc}
- interface
- uses
- symtype,symdef,symbase,
- node,ncal,
- tokens,globtype,globals,constexp;
- { reads a whole expression }
- function expr(dotypecheck:boolean) : tnode;
- { reads an expression without assignements and .. }
- function comp_expr(accept_equal,typeonly:boolean):tnode;
- { reads a single factor }
- function factor(getaddr,typeonly:boolean) : tnode;
- procedure string_dec(var def: tdef; allowtypedef: boolean);
- function parse_paras(__colon,__namedpara : boolean;end_of_paras : ttoken) : tnode;
- { the ID token has to be consumed before calling this function }
- procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
- function get_intconst:TConstExprInt;
- function get_stringconst:string;
- implementation
- uses
- { common }
- cutils,
- { global }
- verbose,
- systems,widestr,
- { symtable }
- symconst,symtable,symsym,defutil,defcmp,
- { module }
- fmodule,ppu,
- { pass 1 }
- pass_1,htypechk,
- nmat,nadd,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
- { parser }
- scanner,
- pbase,pinline,ptype,
- { codegen }
- cgbase,procinfo,cpuinfo
- ;
- { sub_expr(opmultiply) is need to get -1 ** 4 to be
- read as - (1**4) and not (-1)**4 PM }
- type
- Toperator_precedence=(opcompare,opaddition,opmultiply,oppower);
- const
- highest_precedence = oppower;
- function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean):tnode;forward;
- const
- { true, if the inherited call is anonymous }
- anon_inherited : boolean = false;
- { last def found, only used by anon. inherited calls to insert proper type casts }
- srdef : tdef = nil;
- procedure string_dec(var def:tdef; allowtypedef: boolean);
- { reads a string type with optional length }
- { and returns a pointer to the string }
- { definition }
- var
- p : tnode;
- begin
- def:=cshortstringtype;
- consume(_STRING);
- if (token=_LECKKLAMMER) then
- begin
- if not(allowtypedef) then
- Message(parser_e_no_local_para_def);
- consume(_LECKKLAMMER);
- p:=comp_expr(true,false);
- if not is_constintnode(p) then
- begin
- Message(parser_e_illegal_expression);
- { error recovery }
- consume(_RECKKLAMMER);
- end
- else
- begin
- if (tordconstnode(p).value<=0) then
- begin
- Message(parser_e_invalid_string_size);
- tordconstnode(p).value:=255;
- end;
- consume(_RECKKLAMMER);
- if tordconstnode(p).value>255 then
- begin
- { longstring is currently unsupported (CEC)! }
- { t:=tstringdef.createlong(tordconstnode(p).value))}
- Message(parser_e_invalid_string_size);
- tordconstnode(p).value:=255;
- def:=tstringdef.createshort(int64(tordconstnode(p).value));
- end
- else
- if tordconstnode(p).value<>255 then
- def:=tstringdef.createshort(int64(tordconstnode(p).value));
- end;
- p.free;
- end
- else
- begin
- if cs_ansistrings in current_settings.localswitches then
- def:=cansistringtype
- else
- def:=cshortstringtype;
- end;
- end;
- function parse_paras(__colon,__namedpara : boolean;end_of_paras : ttoken) : tnode;
- var
- p1,p2,argname : tnode;
- prev_in_args,
- old_named_args_allowed,
- old_allow_array_constructor : boolean;
- begin
- if token=end_of_paras then
- begin
- parse_paras:=nil;
- exit;
- end;
- { save old values }
- prev_in_args:=in_args;
- old_allow_array_constructor:=allow_array_constructor;
- old_named_args_allowed:=named_args_allowed;
- { set para parsing values }
- in_args:=true;
- named_args_allowed:=false;
- allow_array_constructor:=true;
- p2:=nil;
- repeat
- if __namedpara then
- begin
- if token=_COMMA then
- begin
- { empty parameter }
- p2:=ccallparanode.create(cnothingnode.create,p2);
- end
- else
- begin
- named_args_allowed:=true;
- p1:=comp_expr(true,false);
- named_args_allowed:=false;
- if found_arg_name then
- begin
- argname:=p1;
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,p2);
- tcallparanode(p2).parametername:=argname;
- end
- else
- p2:=ccallparanode.create(p1,p2);
- found_arg_name:=false;
- end;
- end
- else
- begin
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,p2);
- end;
- { it's for the str(l:5,s); }
- if __colon and (token=_COLON) then
- begin
- consume(_COLON);
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,p2);
- include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
- if try_to_consume(_COLON) then
- begin
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,p2);
- include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
- end
- end;
- until not try_to_consume(_COMMA);
- allow_array_constructor:=old_allow_array_constructor;
- in_args:=prev_in_args;
- named_args_allowed:=old_named_args_allowed;
- parse_paras:=p2;
- end;
- function gen_c_style_operator(ntyp:tnodetype;p1,p2:tnode) : tnode;
- var
- hp : tnode;
- hdef : tdef;
- temp : ttempcreatenode;
- newstatement : tstatementnode;
- begin
- { Properties are not allowed, because the write can
- be different from the read }
- if (nf_isproperty in p1.flags) then
- begin
- Message(type_e_variable_id_expected);
- { We can continue with the loading,
- it'll not create errors. Only the expected
- result can be wrong }
- end;
- hp:=p1;
- while assigned(hp) and
- (hp.nodetype in [derefn,subscriptn,vecn,typeconvn]) do
- hp:=tunarynode(hp).left;
- if not assigned(hp) then
- internalerror(200410121);
- if (hp.nodetype=calln) then
- begin
- typecheckpass(p1);
- result:=internalstatements(newstatement);
- hdef:=tpointerdef.create(p1.resultdef);
- temp:=ctempcreatenode.create(hdef,sizeof(pint),tt_persistent,false);
- addstatement(newstatement,temp);
- addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),caddrnode.create_internal(p1)));
- addstatement(newstatement,cassignmentnode.create(
- cderefnode.create(ctemprefnode.create(temp)),
- caddnode.create(ntyp,
- cderefnode.create(ctemprefnode.create(temp)),
- p2)));
- addstatement(newstatement,ctempdeletenode.create(temp));
- end
- else
- result:=cassignmentnode.create(p1,caddnode.create(ntyp,p1.getcopy,p2));
- end;
- function statement_syssym(l : byte) : tnode;
- var
- p1,p2,paras : tnode;
- err,
- prev_in_args : boolean;
- begin
- prev_in_args:=in_args;
- case l of
- in_new_x :
- begin
- if afterassignment or in_args then
- statement_syssym:=new_function
- else
- statement_syssym:=new_dispose_statement(true);
- end;
- in_dispose_x :
- begin
- statement_syssym:=new_dispose_statement(false);
- end;
- in_ord_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- p1:=geninlinenode(in_ord_x,false,p1);
- statement_syssym := p1;
- end;
- in_exit :
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- if not (m_mac in current_settings.modeswitches) then
- begin
- if not(try_to_consume(_RKLAMMER)) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- if (not assigned(current_procinfo) or
- is_void(current_procinfo.procdef.returndef)) then
- begin
- Message(parser_e_void_function);
- { recovery }
- p1.free;
- p1:=nil;
- end;
- end
- else
- p1:=nil;
- end
- else
- begin
- if not (current_procinfo.procdef.procsym.name = pattern) then
- Message(parser_e_macpas_exit_wrong_param);
- consume(_ID);
- consume(_RKLAMMER);
- p1:=nil;
- end
- end
- else
- p1:=nil;
- statement_syssym:=cexitnode.create(p1);
- end;
- in_break :
- begin
- statement_syssym:=cbreaknode.create
- end;
- in_continue :
- begin
- statement_syssym:=ccontinuenode.create
- end;
- in_leave :
- begin
- if m_mac in current_settings.modeswitches then
- statement_syssym:=cbreaknode.create
- else
- begin
- Message1(sym_e_id_not_found, orgpattern);
- statement_syssym:=cerrornode.create;
- end;
- end;
- in_cycle :
- begin
- if m_mac in current_settings.modeswitches then
- statement_syssym:=ccontinuenode.create
- else
- begin
- Message1(sym_e_id_not_found, orgpattern);
- statement_syssym:=cerrornode.create;
- end;
- end;
- in_typeof_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- if p1.nodetype=typen then
- ttypenode(p1).allowed:=true;
- { Allow classrefdef, which is required for
- Typeof(self) in static class methods }
- if not(is_objc_class_or_protocol(p1.resultdef)) and
- ((p1.resultdef.typ = objectdef) or
- (assigned(current_procinfo) and
- ((po_classmethod in current_procinfo.procdef.procoptions) or
- (po_staticmethod in current_procinfo.procdef.procoptions)) and
- (p1.resultdef.typ=classrefdef))) then
- statement_syssym:=geninlinenode(in_typeof_x,false,p1)
- else
- begin
- Message(parser_e_class_id_expected);
- p1.destroy;
- statement_syssym:=cerrornode.create;
- end;
- end;
- in_sizeof_x,
- in_bitsizeof_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- if (p1.nodetype<>typen) and
- (
- (is_object(p1.resultdef) and
- (oo_has_constructor in tobjectdef(p1.resultdef).objectoptions)) or
- is_open_array(p1.resultdef) or
- is_array_of_const(p1.resultdef) or
- is_open_string(p1.resultdef)
- ) then
- begin
- statement_syssym:=geninlinenode(in_sizeof_x,false,p1);
- { no packed bit support for these things }
- if (l = in_bitsizeof_x) then
- statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sinttype,true));
- end
- else
- begin
- { allow helpers for SizeOf and BitSizeOf }
- if p1.nodetype=typen then
- ttypenode(p1).helperallowed:=true;
- if (p1.resultdef.typ=forwarddef) then
- Message1(type_e_type_is_not_completly_defined,tforwarddef(p1.resultdef).tosymname^);
- if (l = in_sizeof_x) or
- (not((p1.nodetype = vecn) and
- is_packed_array(tvecnode(p1).left.resultdef)) and
- not((p1.nodetype = subscriptn) and
- is_packed_record_or_object(tsubscriptnode(p1).left.resultdef))) then
- begin
- statement_syssym:=cordconstnode.create(p1.resultdef.size,sinttype,true);
- if (l = in_bitsizeof_x) then
- statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sinttype,true));
- end
- else
- statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,true);
- { p1 not needed !}
- p1.destroy;
- end;
- end;
- in_typeinfo_x,
- in_objc_encode_x :
- begin
- if (l=in_typeinfo_x) or
- (m_objectivec1 in current_settings.modeswitches) then
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- { When reading a class type it is parsed as loadvmtaddrn,
- typeinfo only needs the type so we remove the loadvmtaddrn }
- if p1.nodetype=loadvmtaddrn then
- begin
- p2:=tloadvmtaddrnode(p1).left;
- tloadvmtaddrnode(p1).left:=nil;
- p1.free;
- p1:=p2;
- end;
- if p1.nodetype=typen then
- begin
- ttypenode(p1).allowed:=true;
- { allow helpers for TypeInfo }
- if l=in_typeinfo_x then
- ttypenode(p1).helperallowed:=true;
- end;
- { else
- begin
- p1.destroy;
- p1:=cerrornode.create;
- Message(parser_e_illegal_parameter_list);
- end;}
- consume(_RKLAMMER);
- p2:=geninlinenode(l,false,p1);
- statement_syssym:=p2;
- end
- else
- begin
- Message1(sym_e_id_not_found, orgpattern);
- statement_syssym:=cerrornode.create;
- end;
- end;
- in_unaligned_x :
- begin
- err:=false;
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,nil);
- p2:=geninlinenode(in_unaligned_x,false,p2);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_assigned_x :
- begin
- err:=false;
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- { When reading a class type it is parsed as loadvmtaddrn,
- typeinfo only needs the type so we remove the loadvmtaddrn }
- if p1.nodetype=loadvmtaddrn then
- begin
- p2:=tloadvmtaddrnode(p1).left;
- tloadvmtaddrnode(p1).left:=nil;
- p1.free;
- p1:=p2;
- end;
- if not codegenerror then
- begin
- case p1.resultdef.typ of
- procdef, { procvar }
- pointerdef,
- procvardef,
- classrefdef : ;
- objectdef :
- if not is_implicit_pointer_object_type(p1.resultdef) then
- begin
- Message(parser_e_illegal_parameter_list);
- err:=true;
- end;
- arraydef :
- if not is_dynamic_array(p1.resultdef) then
- begin
- Message(parser_e_illegal_parameter_list);
- err:=true;
- end;
- else
- begin
- Message(parser_e_illegal_parameter_list);
- err:=true;
- end;
- end;
- end
- else
- err:=true;
- if not err then
- begin
- p2:=ccallparanode.create(p1,nil);
- p2:=geninlinenode(in_assigned_x,false,p2);
- end
- else
- begin
- p1.free;
- p2:=cerrornode.create;
- end;
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_addr_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p1:=caddrnode.create(p1);
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- in_ofs_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p1:=caddrnode.create(p1);
- do_typecheckpass(p1);
- { Ofs() returns a cardinal/qword, not a pointer }
- p1.resultdef:=uinttype;
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- in_seg_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p1:=geninlinenode(in_seg_x,false,p1);
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- in_high_x,
- in_low_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p2:=geninlinenode(l,false,p1);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_succ_x,
- in_pred_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p2:=geninlinenode(l,false,p1);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_inc_x,
- in_dec_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- if try_to_consume(_COMMA) then
- p2:=ccallparanode.create(comp_expr(true,false),nil)
- else
- p2:=nil;
- p2:=ccallparanode.create(p1,p2);
- statement_syssym:=geninlinenode(l,false,p2);
- consume(_RKLAMMER);
- end;
- in_slice_x:
- begin
- if not(in_args) then
- begin
- message(parser_e_illegal_slice);
- consume(_LKLAMMER);
- in_args:=true;
- comp_expr(true,false).free;
- if try_to_consume(_COMMA) then
- comp_expr(true,false).free;
- statement_syssym:=cerrornode.create;
- consume(_RKLAMMER);
- end
- else
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- Consume(_COMMA);
- if not(codegenerror) then
- p2:=ccallparanode.create(comp_expr(true,false),nil)
- else
- p2:=cerrornode.create;
- p2:=ccallparanode.create(p1,p2);
- statement_syssym:=geninlinenode(l,false,p2);
- consume(_RKLAMMER);
- end;
- end;
- in_initialize_x:
- begin
- statement_syssym:=inline_initialize;
- end;
- in_finalize_x:
- begin
- statement_syssym:=inline_finalize;
- end;
- in_copy_x:
- begin
- statement_syssym:=inline_copy;
- end;
- in_concat_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- { Translate to x:=x+y[+z]. The addnode will do the
- type checking }
- p2:=nil;
- repeat
- p1:=comp_expr(true,false);
- if p2<>nil then
- p2:=caddnode.create(addn,p2,p1)
- else
- begin
- { Force string type if it isn't yet }
- if not(
- (p1.resultdef.typ=stringdef) or
- is_chararray(p1.resultdef) or
- is_char(p1.resultdef)
- ) then
- inserttypeconv(p1,cshortstringtype);
- p2:=p1;
- end;
- until not try_to_consume(_COMMA);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_read_x,
- in_readln_x,
- in_readstr_x:
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- paras:=parse_paras(false,false,_RKLAMMER);
- consume(_RKLAMMER);
- end
- else
- paras:=nil;
- p1:=geninlinenode(l,false,paras);
- statement_syssym := p1;
- end;
- in_setlength_x:
- begin
- statement_syssym := inline_setlength;
- end;
- in_objc_selector_x:
- begin
- if (m_objectivec1 in current_settings.modeswitches) then
- begin
- consume(_LKLAMMER);
- in_args:=true;
- { don't turn procsyms into calls (getaddr = true) }
- p1:=factor(true,false);
- p2:=geninlinenode(l,false,p1);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end
- else
- begin
- Message1(sym_e_id_not_found, orgpattern);
- statement_syssym:=cerrornode.create;
- end;
- end;
- in_length_x:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p2:=geninlinenode(l,false,p1);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- end;
- in_write_x,
- in_writeln_x,
- in_writestr_x :
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- paras:=parse_paras(true,false,_RKLAMMER);
- consume(_RKLAMMER);
- end
- else
- paras:=nil;
- p1 := geninlinenode(l,false,paras);
- statement_syssym := p1;
- end;
- in_str_x_string :
- begin
- consume(_LKLAMMER);
- paras:=parse_paras(true,false,_RKLAMMER);
- consume(_RKLAMMER);
- p1 := geninlinenode(l,false,paras);
- statement_syssym := p1;
- end;
- in_val_x:
- Begin
- consume(_LKLAMMER);
- in_args := true;
- p1:= ccallparanode.create(comp_expr(true,false), nil);
- consume(_COMMA);
- p2 := ccallparanode.create(comp_expr(true,false),p1);
- if try_to_consume(_COMMA) then
- p2 := ccallparanode.create(comp_expr(true,false),p2);
- consume(_RKLAMMER);
- p2 := geninlinenode(l,false,p2);
- statement_syssym := p2;
- End;
- in_include_x_y,
- in_exclude_x_y :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- consume(_COMMA);
- p2:=comp_expr(true,false);
- statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
- consume(_RKLAMMER);
- end;
- in_pack_x_y_z,
- in_unpack_x_y_z :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- consume(_COMMA);
- p2:=comp_expr(true,false);
- consume(_COMMA);
- paras:=comp_expr(true,false);
- statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,ccallparanode.create(paras,nil))));
- consume(_RKLAMMER);
- end;
- in_assert_x_y :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- if try_to_consume(_COMMA) then
- p2:=comp_expr(true,false)
- else
- begin
- { then insert an empty string }
- p2:=cstringconstnode.createstr('');
- end;
- statement_syssym:=geninlinenode(l,false,ccallparanode.create(p1,ccallparanode.create(p2,nil)));
- consume(_RKLAMMER);
- end;
- in_get_frame:
- begin
- statement_syssym:=geninlinenode(l,false,nil);
- end;
- (*
- in_get_caller_frame:
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- {You used to call get_caller_frame as get_caller_frame(get_frame),
- however, as a stack frame may not exist, it does more harm than
- good, so ignore it.}
- in_args:=true;
- p1:=comp_expr(true,false);
- p1.destroy;
- consume(_RKLAMMER);
- end;
- statement_syssym:=geninlinenode(l,false,nil);
- end;
- *)
- else
- internalerror(15);
- end;
- in_args:=prev_in_args;
- end;
- function maybe_load_methodpointer(st:TSymtable;var p1:tnode):boolean;
- begin
- maybe_load_methodpointer:=false;
- if not assigned(p1) then
- begin
- case st.symtabletype of
- withsymtable :
- begin
- if (st.defowner.typ=objectdef) then
- p1:=tnode(twithsymtable(st).withrefnode).getcopy;
- end;
- ObjectSymtable,
- recordsymtable:
- begin
- { We are calling from the static class method which has no self node }
- if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
- p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
- else
- p1:=load_self_node;
- { We are calling a member }
- maybe_load_methodpointer:=true;
- end;
- end;
- end;
- end;
- { reads the parameter for a subroutine call }
- procedure do_proc_call(sym:tsym;st:TSymtable;obj:tabstractrecorddef;getaddr:boolean;var again : boolean;var p1:tnode;callflags:tcallnodeflags);
- var
- membercall,
- prevafterassn : boolean;
- i : integer;
- para,p2 : tnode;
- currpara : tparavarsym;
- aprocdef : tprocdef;
- begin
- prevafterassn:=afterassignment;
- afterassignment:=false;
- membercall:=false;
- aprocdef:=nil;
- { when it is a call to a member we need to load the
- methodpointer first
- }
- membercall:=maybe_load_methodpointer(st,p1);
- { When we are expecting a procvar we also need
- to get the address in some cases }
- if assigned(getprocvardef) then
- begin
- if (block_type=bt_const) or
- getaddr then
- begin
- aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
- getaddr:=true;
- end
- else
- if (m_tp_procvar in current_settings.modeswitches) or
- (m_mac_procvar in current_settings.modeswitches) then
- begin
- aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
- if assigned(aprocdef) then
- getaddr:=true;
- end;
- end;
- { only need to get the address of the procedure? }
- if getaddr then
- begin
- { Retrieve info which procvar to call. For tp_procvar the
- aprocdef is already loaded above so we can reuse it }
- if not assigned(aprocdef) and
- assigned(getprocvardef) then
- aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
- { generate a methodcallnode or proccallnode }
- { we shouldn't convert things like @tcollection.load }
- p2:=cloadnode.create_procvar(sym,aprocdef,st);
- if assigned(p1) then
- begin
- { for loading methodpointer of an inherited function
- we use self as instance and load the address of
- the function directly and not through the vmt (PFV) }
- if (cnf_inherited in callflags) then
- begin
- include(p2.flags,nf_inherited);
- p1.free;
- p1:=load_self_node;
- end;
- if (p1.nodetype<>typen) then
- tloadnode(p2).set_mp(p1)
- else
- p1.free;
- end;
- p1:=p2;
- { no postfix operators }
- again:=false;
- end
- else
- begin
- para:=nil;
- if anon_inherited then
- begin
- if not assigned(current_procinfo) then
- internalerror(200305054);
- for i:=0 to current_procinfo.procdef.paras.count-1 do
- begin
- currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
- if not(vo_is_hidden_para in currpara.varoptions) then
- begin
- { inheritance by msgint? }
- if assigned(srdef) then
- { anonymous inherited via msgid calls only require a var parameter for
- both methods, so we need some type casting here }
- para:=ccallparanode.create(ctypeconvnode.create_internal(ctypeconvnode.create_internal(
- cloadnode.create(currpara,currpara.owner),cformaltype),tparavarsym(tprocdef(srdef).paras[i]).vardef),
- para)
- else
- para:=ccallparanode.create(cloadnode.create(currpara,currpara.owner),para);
- end;
- end;
- end
- else
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- para:=parse_paras(false,false,_RKLAMMER);
- consume(_RKLAMMER);
- end;
- end;
- { indicate if this call was generated by a member and
- no explicit self is used, this is needed to determine
- how to handle a destructor call (PFV) }
- if membercall then
- include(callflags,cnf_member_call);
- if assigned(obj) then
- begin
- if not (st.symtabletype in [ObjectSymtable,recordsymtable]) then
- internalerror(200310031);
- p1:=ccallnode.create(para,tprocsym(sym),obj.symtable,p1,callflags);
- end
- else
- p1:=ccallnode.create(para,tprocsym(sym),st,p1,callflags);
- end;
- afterassignment:=prevafterassn;
- end;
- procedure handle_procvar(pv : tprocvardef;var p2 : tnode);
- var
- hp,hp2 : tnode;
- hpp : ^tnode;
- currprocdef : tprocdef;
- begin
- if not assigned(pv) then
- internalerror(200301121);
- if (m_tp_procvar in current_settings.modeswitches) or
- (m_mac_procvar in current_settings.modeswitches) then
- begin
- hp:=p2;
- hpp:=@p2;
- while assigned(hp) and
- (hp.nodetype=typeconvn) do
- begin
- hp:=ttypeconvnode(hp).left;
- { save orignal address of the old tree so we can replace the node }
- hpp:=@hp;
- end;
- if (hp.nodetype=calln) and
- { a procvar can't have parameters! }
- not assigned(tcallnode(hp).left) then
- begin
- currprocdef:=tcallnode(hp).symtableprocentry.Find_procdef_byprocvardef(pv);
- if assigned(currprocdef) then
- begin
- hp2:=cloadnode.create_procvar(tprocsym(tcallnode(hp).symtableprocentry),currprocdef,tcallnode(hp).symtableproc);
- if (po_methodpointer in pv.procoptions) then
- tloadnode(hp2).set_mp(tcallnode(hp).methodpointer.getcopy);
- hp.destroy;
- { replace the old callnode with the new loadnode }
- hpp^:=hp2;
- end;
- end;
- end;
- end;
- { checks whether sym is a static field and if so, translates the access
- to the appropriate node tree }
- function handle_staticfield_access(sym: tsym; nested: boolean; var p1: tnode): boolean;
- var
- static_name: shortstring;
- srsymtable: tsymtable;
- begin
- result:=false;
- { generate access code }
- if (sp_static in sym.symoptions) then
- begin
- result:=true;
- if not nested then
- static_name:=lower(sym.owner.name^)+'_'+sym.name
- else
- static_name:=lower(generate_nested_name(sym.owner,'_'))+'_'+sym.name;
- if sym.owner.defowner.typ=objectdef then
- searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable,true)
- else
- searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
- if assigned(sym) then
- check_hints(sym,sym.symoptions,sym.deprecatedmsg);
- p1.free;
- p1:=nil;
- { static syms are always stored as absolutevarsym to handle scope and storage properly }
- propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
- end;
- end;
- { the following procedure handles the access to a property symbol }
- procedure handle_propertysym(propsym : tpropertysym;st : TSymtable;var p1 : tnode);
- var
- paras : tnode;
- p2 : tnode;
- membercall : boolean;
- callflags : tcallnodeflags;
- propaccesslist : tpropaccesslist;
- sym: tsym;
- begin
- { property parameters? read them only if the property really }
- { has parameters }
- paras:=nil;
- if (ppo_hasparameters in propsym.propoptions) then
- begin
- if try_to_consume(_LECKKLAMMER) then
- begin
- paras:=parse_paras(false,false,_RECKKLAMMER);
- consume(_RECKKLAMMER);
- end;
- end;
- { indexed property }
- if (ppo_indexed in propsym.propoptions) then
- begin
- p2:=cordconstnode.create(propsym.index,propsym.indexdef,true);
- paras:=ccallparanode.create(p2,paras);
- end;
- { we need only a write property if a := follows }
- { if not(afterassignment) and not(in_args) then }
- if token=_ASSIGNMENT then
- begin
- if getpropaccesslist(propsym,palt_write,propaccesslist) then
- begin
- sym:=propaccesslist.firstsym^.sym;
- case sym.typ of
- procsym :
- begin
- callflags:=[];
- { generate the method call }
- membercall:=maybe_load_methodpointer(st,p1);
- if membercall then
- include(callflags,cnf_member_call);
- p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
- addsymref(sym);
- paras:=nil;
- consume(_ASSIGNMENT);
- { read the expression }
- if propsym.propdef.typ=procvardef then
- getprocvardef:=tprocvardef(propsym.propdef);
- p2:=comp_expr(true,false);
- if assigned(getprocvardef) then
- handle_procvar(getprocvardef,p2);
- tcallnode(p1).left:=ccallparanode.create(p2,tcallnode(p1).left);
- { mark as property, both the tcallnode and the real call block }
- include(p1.flags,nf_isproperty);
- getprocvardef:=nil;
- end;
- fieldvarsym :
- begin
- { generate access code }
- if not handle_staticfield_access(sym,false,p1) then
- propaccesslist_to_node(p1,st,propaccesslist);
- include(p1.flags,nf_isproperty);
- consume(_ASSIGNMENT);
- { read the expression }
- p2:=comp_expr(true,false);
- p1:=cassignmentnode.create(p1,p2);
- end
- else
- begin
- p1:=cerrornode.create;
- Message(parser_e_no_procedure_to_access_property);
- end;
- end;
- end
- else
- begin
- p1:=cerrornode.create;
- Message(parser_e_no_procedure_to_access_property);
- end;
- end
- else
- begin
- if getpropaccesslist(propsym,palt_read,propaccesslist) then
- begin
- sym := propaccesslist.firstsym^.sym;
- case sym.typ of
- fieldvarsym :
- begin
- { generate access code }
- if not handle_staticfield_access(sym,false,p1) then
- propaccesslist_to_node(p1,st,propaccesslist);
- include(p1.flags,nf_isproperty);
- end;
- procsym :
- begin
- callflags:=[];
- { generate the method call }
- membercall:=maybe_load_methodpointer(st,p1);
- if membercall then
- include(callflags,cnf_member_call);
- p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
- paras:=nil;
- include(p1.flags,nf_isproperty);
- end
- else
- begin
- p1:=cerrornode.create;
- Message(type_e_mismatch);
- end;
- end;
- end
- else
- begin
- { error, no function to read property }
- p1:=cerrornode.create;
- Message(parser_e_no_procedure_to_access_property);
- end;
- end;
- { release paras if not used }
- if assigned(paras) then
- paras.free;
- end;
- { the ID token has to be consumed before calling this function }
- procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
- var
- isclassref : boolean;
- begin
- if sym=nil then
- begin
- { pattern is still valid unless
- there is another ID just after the ID of sym }
- Message1(sym_e_id_no_member,orgpattern);
- p1.free;
- p1:=cerrornode.create;
- { try to clean up }
- again:=false;
- end
- else
- begin
- if assigned(p1) then
- begin
- if not assigned(p1.resultdef) then
- do_typecheckpass(p1);
- isclassref:=(p1.resultdef.typ=classrefdef);
- end
- else
- isclassref:=false;
- { we assume, that only procsyms and varsyms are in an object }
- { symbol table, for classes, properties are allowed }
- case sym.typ of
- procsym:
- begin
- do_proc_call(sym,sym.owner,structh,
- (getaddr and not(token in [_CARET,_POINT])),
- again,p1,callflags);
- { we need to know which procedure is called }
- do_typecheckpass(p1);
- { calling using classref? }
- if isclassref and
- (p1.nodetype=calln) and
- assigned(tcallnode(p1).procdefinition) and
- not(po_classmethod in tcallnode(p1).procdefinition.procoptions) and
- not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) then
- Message(parser_e_only_class_members_via_class_ref);
- end;
- fieldvarsym:
- begin
- if not handle_staticfield_access(sym,true,p1) then
- begin
- if isclassref then
- if assigned(p1) and
- (
- is_self_node(p1) or
- (assigned(current_procinfo) and (current_procinfo.procdef.no_self_node) and
- (current_procinfo.procdef.struct=structh))) then
- Message(parser_e_only_class_members)
- else
- Message(parser_e_only_class_members_via_class_ref);
- p1:=csubscriptnode.create(sym,p1);
- end;
- end;
- propertysym:
- begin
- if isclassref and not (sp_static in sym.symoptions) then
- Message(parser_e_only_class_members_via_class_ref);
- handle_propertysym(tpropertysym(sym),sym.owner,p1);
- end;
- typesym:
- begin
- p1.free;
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- p1:=ctypeconvnode.create_explicit(p1,ttypesym(sym).typedef);
- end
- else
- begin
- p1:=ctypenode.create(ttypesym(sym).typedef);
- if (is_class(ttypesym(sym).typedef) or is_objcclass(ttypesym(sym).typedef)) and
- not(block_type in [bt_type,bt_const_type,bt_var_type]) then
- p1:=cloadvmtaddrnode.create(p1);
- end;
- end;
- constsym:
- begin
- p1.free;
- p1:=genconstsymtree(tconstsym(sym));
- end;
- staticvarsym:
- begin
- { typed constant is a staticvarsym
- now they are absolutevarsym }
- p1.free;
- p1:=cloadnode.create(sym,sym.Owner);
- end;
- absolutevarsym:
- begin
- p1.free;
- p1:=nil;
- { typed constants are absolutebarsyms now to handle storage properly }
- propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
- end
- else
- internalerror(16);
- end;
- end;
- end;
- {****************************************************************************
- Factor
- ****************************************************************************}
- function is_member_read(sym: tsym; st: tsymtable; var p1: tnode;
- out memberparentdef: tdef): boolean;
- var
- hdef : tdef;
- begin
- result:=true;
- memberparentdef:=nil;
- case st.symtabletype of
- ObjectSymtable,
- recordsymtable:
- begin
- memberparentdef:=tdef(st.defowner);
- exit;
- end;
- WithSymtable:
- begin
- if assigned(p1) then
- internalerror(2007012002);
- hdef:=tnode(twithsymtable(st).withrefnode).resultdef;
- p1:=tnode(twithsymtable(st).withrefnode).getcopy;
- if not(hdef.typ in [objectdef,classrefdef]) then
- exit;
- if (hdef.typ=classrefdef) then
- hdef:=tclassrefdef(hdef).pointeddef;
- memberparentdef:=hdef;
- end;
- else
- result:=false;
- end;
- end;
- {$maxfpuregisters 0}
- function factor(getaddr,typeonly:boolean) : tnode;
- {---------------------------------------------
- Factor_read_id
- ---------------------------------------------}
- procedure factor_read_id(out p1:tnode;var again:boolean);
- var
- srsym : tsym;
- srsymtable : TSymtable;
- hdef : tdef;
- orgstoredpattern,
- storedpattern : string;
- callflags: tcallnodeflags;
- t : ttoken;
- unit_found : boolean;
- begin
- { allow post fix operators }
- again:=true;
- { first check for identifier }
- if token<>_ID then
- begin
- srsym:=generrorsym;
- srsymtable:=nil;
- consume(_ID);
- end
- else
- begin
- if typeonly then
- searchsym_type(pattern,srsym,srsymtable)
- else
- searchsym(pattern,srsym,srsymtable);
- { handle unit specification like System.Writeln }
- unit_found:=try_consume_unitsym(srsym,srsymtable,t);
- storedpattern:=pattern;
- orgstoredpattern:=orgpattern;
- consume(t);
- { named parameter support }
- found_arg_name:=false;
- if not(unit_found) and
- named_args_allowed and
- (token=_ASSIGNMENT) then
- begin
- found_arg_name:=true;
- p1:=cstringconstnode.createstr(storedpattern);
- consume(_ASSIGNMENT);
- exit;
- end;
- { if nothing found give error and return errorsym }
- if assigned(srsym) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg)
- else
- begin
- identifier_not_found(orgstoredpattern);
- srsym:=generrorsym;
- srsymtable:=nil;
- end;
- end;
- { Access to funcret or need to call the function? }
- if (srsym.typ in [absolutevarsym,localvarsym,paravarsym]) and
- (vo_is_funcret in tabstractvarsym(srsym).varoptions) and
- { result(x) is not allowed }
- not(vo_is_result in tabstractvarsym(srsym).varoptions) and
- (
- (token=_LKLAMMER) or
- (
- (
- (m_tp7 in current_settings.modeswitches) or
- (m_delphi in current_settings.modeswitches)
- ) and
- (afterassignment or in_args)
- )
- ) then
- begin
- hdef:=tdef(srsym.owner.defowner);
- if assigned(hdef) and
- (hdef.typ=procdef) then
- srsym:=tprocdef(hdef).procsym
- else
- begin
- Message(parser_e_illegal_expression);
- srsym:=generrorsym;
- end;
- srsymtable:=srsym.owner;
- end;
- begin
- case srsym.typ of
- absolutevarsym :
- begin
- if (tabsolutevarsym(srsym).abstyp=tovar) then
- begin
- p1:=nil;
- propaccesslist_to_node(p1,nil,tabsolutevarsym(srsym).ref);
- p1:=ctypeconvnode.create(p1,tabsolutevarsym(srsym).vardef);
- include(p1.flags,nf_absolute);
- end
- else
- p1:=cloadnode.create(srsym,srsymtable);
- end;
- staticvarsym,
- localvarsym,
- paravarsym,
- fieldvarsym :
- begin
- { check if we are reading a field of an object/class/ }
- { record. is_member_read() will deal with withsymtables }
- { if needed. }
- p1:=nil;
- if is_member_read(srsym,srsymtable,p1,hdef) then
- begin
- { if the field was originally found in an }
- { objectsymtable, it means it's part of self
- if only method from which it was called is
- not class static }
- if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) then
- if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
- p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
- else
- p1:=load_self_node;
- { now, if the field itself is part of an objectsymtab }
- { (it can be even if it was found in a withsymtable, }
- { e.g., "with classinstance do field := 5"), then }
- { let do_member_read handle it }
- if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
- else
- { otherwise it's a regular record subscript }
- p1:=csubscriptnode.create(srsym,p1);
- end
- else
- { regular non-field load }
- p1:=cloadnode.create(srsym,srsymtable);
- end;
- syssym :
- begin
- p1:=statement_syssym(tsyssym(srsym).number);
- end;
- typesym :
- begin
- hdef:=ttypesym(srsym).typedef;
- if not assigned(hdef) then
- begin
- again:=false;
- end
- else
- begin
- { We need to know if this unit uses Variants }
- if (hdef=cvarianttype) and
- not(cs_compilesystem in current_settings.moduleswitches) then
- current_module.flags:=current_module.flags or uf_uses_variants;
- { if we get a generic then check that it is not an inline specialization }
- if (df_generic in hdef.defoptions) and
- (token=_LT) and
- (m_delphi in current_settings.modeswitches) then
- generate_specialization(hdef,false);
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- { type casts to class helpers aren't allowed }
- if is_objectpascal_helper(hdef) then
- Message(parser_e_no_category_as_types)
- { recovery by not creating a conversion node }
- else
- p1:=ctypeconvnode.create_explicit(p1,hdef);
- end
- else { not LKLAMMER }
- if (token=_POINT) and
- (is_object(hdef) or is_record(hdef)) then
- begin
- consume(_POINT);
- { handles calling methods declared in parent objects
- using "parentobject.methodname()" }
- if assigned(current_structdef) and
- not(getaddr) and
- current_structdef.is_related(hdef) then
- begin
- p1:=ctypenode.create(hdef);
- { search also in inherited methods }
- searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,true);
- if assigned(srsym) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(tabstractrecorddef(hdef),false,srsym,p1,again,[]);
- end
- else
- begin
- { handles:
- * @TObject.Load
- * static methods and variables }
- p1:=ctypenode.create(hdef);
- { TP allows also @TMenu.Load if Load is only }
- { defined in an anchestor class }
- srsym:=search_struct_member(tabstractrecorddef(hdef),pattern);
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[]);
- end
- else
- Message1(sym_e_id_no_member,orgpattern);
- end;
- end
- else
- begin
- { Normally here would be the check against the usage
- of "TClassHelper.Something", but as that might be
- used inside of system symbols like sizeof and
- typeinfo this check is put into ttypenode.pass_1
- (for "TClassHelper" alone) and tcallnode.pass_1
- (for "TClassHelper.Something") }
- { class reference ? }
- if is_class(hdef) or
- is_objcclass(hdef) then
- begin
- if getaddr and (token=_POINT) then
- begin
- consume(_POINT);
- { allows @Object.Method }
- { also allows static methods and variables }
- p1:=ctypenode.create(hdef);
- { TP allows also @TMenu.Load if Load is only }
- { defined in an anchestor class }
- srsym:=search_struct_member(tobjectdef(hdef),pattern);
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[]);
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- consume(_ID);
- end;
- end
- else
- begin
- p1:=ctypenode.create(hdef);
- { For a type block we simply return only
- the type. For all other blocks we return
- a loadvmt node }
- if not(block_type in [bt_type,bt_const_type,bt_var_type]) then
- p1:=cloadvmtaddrnode.create(p1);
- end;
- end
- else
- p1:=ctypenode.create(hdef);
- end;
- end;
- end;
- enumsym :
- begin
- p1:=genenumnode(tenumsym(srsym));
- end;
- constsym :
- begin
- if tconstsym(srsym).consttyp=constresourcestring then
- begin
- p1:=cloadnode.create(srsym,srsymtable);
- do_typecheckpass(p1);
- p1.resultdef:=cansistringtype;
- end
- else
- p1:=genconstsymtree(tconstsym(srsym));
- end;
- procsym :
- begin
- p1:=nil;
- { check if it's a method/class method }
- if is_member_read(srsym,srsymtable,p1,hdef) then
- begin
- { not srsymtable.symtabletype since that can be }
- { withsymtable as well }
- if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
- else
- { no procsyms in records (yet) }
- internalerror(2007012006);
- end
- else
- begin
- { regular procedure/function call }
- if not unit_found then
- callflags:=[]
- else
- callflags:=[cnf_unit_specified];
- do_proc_call(srsym,srsymtable,nil,
- (getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
- again,p1,callflags);
- end;
- end;
- propertysym :
- begin
- p1:=nil;
- { property of a class/object? }
- if is_member_read(srsym,srsymtable,p1,hdef) then
- begin
- if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) then
- if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
- { no self node in static class methods }
- p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
- else
- p1:=load_self_node;
- { not srsymtable.symtabletype since that can be }
- { withsymtable as well }
- if (srsym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[])
- else
- { no propertysyms in records (yet) }
- internalerror(2009111510);
- end
- else
- { no method pointer }
- begin
- handle_propertysym(tpropertysym(srsym),srsymtable,p1);
- end;
- end;
- labelsym :
- begin
- { Support @label }
- if getaddr then
- begin
- if srsym.owner<>current_procinfo.procdef.localst then
- CGMessage(parser_e_label_outside_proc);
- p1:=cloadnode.create(srsym,srsym.owner)
- end
- else
- begin
- consume(_COLON);
- if tlabelsym(srsym).defined then
- Message(sym_e_label_already_defined);
- if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
- begin
- tlabelsym(srsym).nonlocal:=true;
- exclude(current_procinfo.procdef.procoptions,po_inline);
- end;
- if tlabelsym(srsym).nonlocal and
- (current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
- Message(sym_e_interprocgoto_into_init_final_code_not_allowed);
- tlabelsym(srsym).defined:=true;
- p1:=clabelnode.create(nil,tlabelsym(srsym));
- tlabelsym(srsym).code:=p1;
- end;
- end;
- errorsym :
- begin
- p1:=cerrornode.create;
- if try_to_consume(_LKLAMMER) then
- begin
- parse_paras(false,false,_RKLAMMER);
- consume(_RKLAMMER);
- end;
- end;
- else
- begin
- p1:=cerrornode.create;
- Message(parser_e_illegal_expression);
- end;
- end; { end case }
- end;
- end;
- {---------------------------------------------
- Factor_Read_Set
- ---------------------------------------------}
- { Read a set between [] }
- function factor_read_set:tnode;
- var
- p1,p2 : tnode;
- lastp,
- buildp : tarrayconstructornode;
- old_allow_array_constructor : boolean;
- begin
- buildp:=nil;
- { be sure that a least one arrayconstructn is used, also for an
- empty [] }
- if token=_RECKKLAMMER then
- buildp:=carrayconstructornode.create(nil,buildp)
- else
- repeat
- { nested array constructors are not allowed, see also tests/webtbs/tw17213.pp }
- old_allow_array_constructor:=allow_array_constructor;
- allow_array_constructor:=false;
- p1:=comp_expr(true,false);
- if try_to_consume(_POINTPOINT) then
- begin
- p2:=comp_expr(true,false);
- p1:=carrayconstructorrangenode.create(p1,p2);
- end;
- { insert at the end of the tree, to get the correct order }
- if not assigned(buildp) then
- begin
- buildp:=carrayconstructornode.create(p1,nil);
- lastp:=buildp;
- end
- else
- begin
- lastp.right:=carrayconstructornode.create(p1,nil);
- lastp:=tarrayconstructornode(lastp.right);
- end;
- allow_array_constructor:=old_allow_array_constructor;
- { there could be more elements }
- until not try_to_consume(_COMMA);
- factor_read_set:=buildp;
- end;
- {---------------------------------------------
- PostFixOperators
- ---------------------------------------------}
- { returns whether or not p1 has been changed }
- function postfixoperators(var p1:tnode;var again:boolean): boolean;
- { tries to avoid syntax errors after invalid qualifiers }
- procedure recoverconsume_postfixops;
- begin
- repeat
- if not try_to_consume(_CARET) then
- if try_to_consume(_POINT) then
- try_to_consume(_ID)
- else if try_to_consume(_LECKKLAMMER) then
- begin
- repeat
- comp_expr(true,false);
- until not try_to_consume(_COMMA);
- consume(_RECKKLAMMER);
- end
- else if try_to_consume(_LKLAMMER) then
- begin
- repeat
- comp_expr(true,false);
- until not try_to_consume(_COMMA);
- consume(_RKLAMMER);
- end
- else
- break;
- until false;
- end;
- procedure handle_variantarray;
- var
- p4 : tnode;
- newstatement : tstatementnode;
- tempresultvariant,
- temp : ttempcreatenode;
- paras : tcallparanode;
- newblock : tnode;
- countindices : aint;
- begin
- { create statements with call initialize the arguments and
- call fpc_dynarr_setlength }
- newblock:=internalstatements(newstatement);
- { get temp for array of indicies,
- we set the real size later }
- temp:=ctempcreatenode.create(s32inttype,4,tt_persistent,false);
- addstatement(newstatement,temp);
- countindices:=0;
- repeat
- p4:=comp_expr(true,false);
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create_offset(temp,countindices*s32inttype.size),p4));
- inc(countindices);
- until not try_to_consume(_COMMA);
- { set real size }
- temp.size:=countindices*s32inttype.size;
- consume(_RECKKLAMMER);
- { we need only a write access if a := follows }
- if token=_ASSIGNMENT then
- begin
- consume(_ASSIGNMENT);
- p4:=comp_expr(true,false);
- { create call to fpc_vararray_put }
- paras:=ccallparanode.create(cordconstnode.create
- (countindices,s32inttype,true),
- ccallparanode.create(caddrnode.create_internal
- (ctemprefnode.create(temp)),
- ccallparanode.create(ctypeconvnode.create_internal(p4,cvarianttype),
- ccallparanode.create(ctypeconvnode.create_internal(p1,cvarianttype)
- ,nil))));
- addstatement(newstatement,ccallnode.createintern('fpc_vararray_put',paras));
- addstatement(newstatement,ctempdeletenode.create(temp));
- end
- else
- begin
- { create temp for result }
- tempresultvariant:=ctempcreatenode.create(cvarianttype,cvarianttype.size,tt_persistent,true);
- addstatement(newstatement,tempresultvariant);
- { create call to fpc_vararray_get }
- paras:=ccallparanode.create(cordconstnode.create
- (countindices,s32inttype,true),
- ccallparanode.create(caddrnode.create_internal
- (ctemprefnode.create(temp)),
- ccallparanode.create(p1,
- ccallparanode.create(
- ctemprefnode.create(tempresultvariant)
- ,nil))));
- addstatement(newstatement,ccallnode.createintern('fpc_vararray_get',paras));
- addstatement(newstatement,ctempdeletenode.create(temp));
- { the last statement should return the value as
- location and type, this is done be referencing the
- temp and converting it first from a persistent temp to
- normal temp }
- addstatement(newstatement,ctempdeletenode.create_normal_temp(tempresultvariant));
- addstatement(newstatement,ctemprefnode.create(tempresultvariant));
- end;
- p1:=newblock;
- end;
- var
- protsym : tpropertysym;
- p2,p3 : tnode;
- srsym : tsym;
- srsymtable : TSymtable;
- structh : tabstractrecorddef;
- { shouldn't be used that often, so the extra overhead is ok to save
- stack space }
- dispatchstring : ansistring;
- nodechanged : boolean;
- calltype: tdispcalltype;
- label
- skipreckklammercheck;
- begin
- result:=false;
- again:=true;
- while again do
- begin
- { we need the resultdef }
- do_typecheckpass_changed(p1,nodechanged);
- result:=result or nodechanged;
- if codegenerror then
- begin
- recoverconsume_postfixops;
- exit;
- end;
- { handle token }
- case token of
- _CARET:
- begin
- consume(_CARET);
- { support tp/mac procvar^ if the procvar returns a
- pointer type }
- if ((m_tp_procvar in current_settings.modeswitches) or
- (m_mac_procvar in current_settings.modeswitches)) and
- (p1.resultdef.typ=procvardef) and
- (tprocvardef(p1.resultdef).returndef.typ=pointerdef) then
- begin
- p1:=ccallnode.create_procvar(nil,p1);
- typecheckpass(p1);
- end;
- if (p1.resultdef.typ<>pointerdef) then
- begin
- { ^ as binary operator is a problem!!!! (FK) }
- again:=false;
- Message(parser_e_invalid_qualifier);
- recoverconsume_postfixops;
- p1.destroy;
- p1:=cerrornode.create;
- end
- else
- p1:=cderefnode.create(p1);
- end;
- _LECKKLAMMER:
- begin
- if is_class_or_interface_or_object(p1.resultdef) or
- is_dispinterface(p1.resultdef) or is_record(p1.resultdef) then
- begin
- { default property }
- protsym:=search_default_property(tabstractrecorddef(p1.resultdef));
- if not(assigned(protsym)) then
- begin
- p1.destroy;
- p1:=cerrornode.create;
- again:=false;
- message(parser_e_no_default_property_available);
- end
- else
- begin
- { The property symbol is referenced indirect }
- protsym.IncRefCount;
- handle_propertysym(protsym,protsym.owner,p1);
- end;
- end
- else
- begin
- consume(_LECKKLAMMER);
- repeat
- { in all of the cases below, p1 is changed }
- case p1.resultdef.typ of
- pointerdef:
- begin
- { support delphi autoderef }
- if (tpointerdef(p1.resultdef).pointeddef.typ=arraydef) and
- (m_autoderef in current_settings.modeswitches) then
- p1:=cderefnode.create(p1);
- p2:=comp_expr(true,false);
- { Support Pbytevar[0..9] which returns array [0..9].}
- if try_to_consume(_POINTPOINT) then
- p2:=crangenode.create(p2,comp_expr(true,false));
- p1:=cvecnode.create(p1,p2);
- end;
- variantdef:
- begin
- handle_variantarray;
- { the RECKKLAMMER is already read }
- goto skipreckklammercheck;
- end;
- stringdef :
- begin
- p2:=comp_expr(true,false);
- { Support string[0..9] which returns array [0..9] of char.}
- if try_to_consume(_POINTPOINT) then
- p2:=crangenode.create(p2,comp_expr(true,false));
- p1:=cvecnode.create(p1,p2);
- end;
- arraydef:
- begin
- p2:=comp_expr(true,false);
- { support SEG:OFS for go32v2 Mem[] }
- if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
- (p1.nodetype=loadn) and
- assigned(tloadnode(p1).symtableentry) and
- assigned(tloadnode(p1).symtableentry.owner.name) and
- (tloadnode(p1).symtableentry.owner.name^='SYSTEM') and
- ((tloadnode(p1).symtableentry.name='MEM') or
- (tloadnode(p1).symtableentry.name='MEMW') or
- (tloadnode(p1).symtableentry.name='MEML')) then
- begin
- if try_to_consume(_COLON) then
- begin
- p3:=caddnode.create(muln,cordconstnode.create($10,s32inttype,false),p2);
- p2:=comp_expr(true,false);
- p2:=caddnode.create(addn,p2,p3);
- if try_to_consume(_POINTPOINT) then
- { Support mem[$a000:$0000..$07ff] which returns array [0..$7ff] of memtype.}
- p2:=crangenode.create(p2,caddnode.create(addn,comp_expr(true,false),p3.getcopy));
- p1:=cvecnode.create(p1,p2);
- include(tvecnode(p1).flags,nf_memseg);
- include(tvecnode(p1).flags,nf_memindex);
- end
- else
- begin
- if try_to_consume(_POINTPOINT) then
- { Support mem[$80000000..$80000002] which returns array [0..2] of memtype.}
- p2:=crangenode.create(p2,comp_expr(true,false));
- p1:=cvecnode.create(p1,p2);
- include(tvecnode(p1).flags,nf_memindex);
- end;
- end
- else
- begin
- if try_to_consume(_POINTPOINT) then
- { Support arrayvar[0..9] which returns array [0..9] of arraytype.}
- p2:=crangenode.create(p2,comp_expr(true,false));
- p1:=cvecnode.create(p1,p2);
- end;
- end;
- else
- begin
- if p1.resultdef.typ<>undefineddef then
- Message(parser_e_invalid_qualifier);
- p1.destroy;
- p1:=cerrornode.create;
- comp_expr(true,false);
- again:=false;
- end;
- end;
- do_typecheckpass(p1);
- until not try_to_consume(_COMMA);
- consume(_RECKKLAMMER);
- { handle_variantarray eats the RECKKLAMMER and jumps here }
- skipreckklammercheck:
- end;
- end;
- _POINT :
- begin
- consume(_POINT);
- if (p1.resultdef.typ=pointerdef) and
- (m_autoderef in current_settings.modeswitches) and
- { don't auto-deref objc.id, because then the code
- below for supporting id.anyobjcmethod isn't triggered }
- (p1.resultdef<>objc_idtype) then
- begin
- p1:=cderefnode.create(p1);
- do_typecheckpass(p1);
- end;
- { procvar.<something> can never mean anything so always
- try to call it in case it returns a record/object/... }
- maybe_call_procvar(p1,false);
- case p1.resultdef.typ of
- recorddef:
- begin
- if token=_ID then
- begin
- structh:=tabstractrecorddef(p1.resultdef);
- searchsym_in_record(structh,pattern,srsym,srsymtable);
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(structh,getaddr,srsym,p1,again,[]);
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- p1.destroy;
- p1:=cerrornode.create;
- { try to clean up }
- consume(_ID);
- end;
- end
- else
- consume(_ID);
- end;
- enumdef:
- begin
- if token=_ID then
- begin
- srsym:=tsym(tenumdef(p1.resultdef).symtable.Find(pattern));
- p1.destroy;
- if assigned(srsym) and (srsym.typ=enumsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- p1:=genenumnode(tenumsym(srsym));
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- p1:=cerrornode.create;
- end;
- end;
- consume(_ID);
- end;
- variantdef:
- begin
- { dispatch call? }
- { lhs := v.ident[parameters] -> property get
- lhs := v.ident(parameters) -> method call
- v.ident[parameters] := rhs -> property put
- v.ident(parameters) := rhs -> also property put }
- if token=_ID then
- begin
- dispatchstring:=orgpattern;
- consume(_ID);
- calltype:=dct_method;
- if try_to_consume(_LKLAMMER) then
- begin
- p2:=parse_paras(false,true,_RKLAMMER);
- consume(_RKLAMMER);
- end
- else if try_to_consume(_LECKKLAMMER) then
- begin
- p2:=parse_paras(false,true,_RECKKLAMMER);
- consume(_RECKKLAMMER);
- calltype:=dct_propget;
- end
- else
- p2:=nil;
- { property setter? }
- if (token=_ASSIGNMENT) and not(afterassignment) then
- begin
- consume(_ASSIGNMENT);
- { read the expression }
- p3:=comp_expr(true,false);
- { concat value parameter too }
- p2:=ccallparanode.create(p3,p2);
- p1:=translate_disp_call(p1,p2,dct_propput,dispatchstring,0,voidtype);
- end
- else
- { this is only an approximation
- setting useresult if not necessary is only a waste of time, no more, no less (FK) }
- if afterassignment or in_args or (token<>_SEMICOLON) then
- p1:=translate_disp_call(p1,p2,calltype,dispatchstring,0,cvarianttype)
- else
- p1:=translate_disp_call(p1,p2,calltype,dispatchstring,0,voidtype);
- end
- else { Error }
- Consume(_ID);
- end;
- classrefdef:
- begin
- if token=_ID then
- begin
- structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(structh,getaddr,srsym,p1,again,[]);
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- p1.destroy;
- p1:=cerrornode.create;
- { try to clean up }
- consume(_ID);
- end;
- end
- else { Error }
- Consume(_ID);
- end;
- objectdef:
- begin
- if token=_ID then
- begin
- structh:=tobjectdef(p1.resultdef);
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,true);
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(structh,getaddr,srsym,p1,again,[]);
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- p1.destroy;
- p1:=cerrornode.create;
- { try to clean up }
- consume(_ID);
- end;
- end
- else { Error }
- Consume(_ID);
- end;
- pointerdef:
- begin
- if (p1.resultdef=objc_idtype) then
- begin
- { objc's id type can be used to call any
- Objective-C method of any Objective-C class
- type that's currently in scope }
- if search_objc_method(pattern,srsym,srsymtable) then
- begin
- consume(_ID);
- do_proc_call(srsym,srsymtable,nil,
- (getaddr and not(token in [_CARET,_POINT])),
- again,p1,[cnf_objc_id_call]);
- { we need to know which procedure is called }
- do_typecheckpass(p1);
- end
- else
- begin
- consume(_ID);
- Message(parser_e_methode_id_expected);
- end;
- end
- else
- begin
- Message(parser_e_invalid_qualifier);
- if tpointerdef(p1.resultdef).pointeddef.typ in [recorddef,objectdef,classrefdef] then
- Message(parser_h_maybe_deref_caret_missing);
- end
- end;
- else
- begin
- if p1.resultdef.typ<>undefineddef then
- Message(parser_e_invalid_qualifier);
- p1.destroy;
- p1:=cerrornode.create;
- { Error }
- consume(_ID);
- end;
- end;
- end;
- else
- begin
- { is this a procedure variable ? }
- if assigned(p1.resultdef) and
- (p1.resultdef.typ=procvardef) then
- begin
- { Typenode for typecasting or expecting a procvar }
- if (p1.nodetype=typen) or
- (
- assigned(getprocvardef) and
- equal_defs(p1.resultdef,getprocvardef)
- ) then
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- p1:=ctypeconvnode.create_explicit(p1,p1.resultdef);
- end
- else
- again:=false
- end
- else
- begin
- if try_to_consume(_LKLAMMER) then
- begin
- p2:=parse_paras(false,false,_RKLAMMER);
- consume(_RKLAMMER);
- p1:=ccallnode.create_procvar(p2,p1);
- { proc():= is never possible }
- if token=_ASSIGNMENT then
- begin
- Message(parser_e_illegal_expression);
- p1.free;
- p1:=cerrornode.create;
- again:=false;
- end;
- end
- else
- again:=false;
- end;
- end
- else
- again:=false;
- end;
- end;
- { we only try again if p1 was changed }
- if again or
- (p1.nodetype=errorn) then
- result:=true;
- end; { while again }
- end;
- {---------------------------------------------
- Factor (Main)
- ---------------------------------------------}
- var
- l : longint;
- ic : int64;
- qc : qword;
- p1 : tnode;
- code : integer;
- srsym : tsym;
- srsymtable : TSymtable;
- pd : tprocdef;
- hclassdef : tobjectdef;
- d : bestreal;
- cur : currency;
- hs,hsorg : string;
- hdef : tdef;
- filepos : tfileposinfo;
- again,
- updatefpos,
- nodechanged : boolean;
- begin
- { can't keep a copy of p1 and compare pointers afterwards, because
- p1 may be freed and reallocated in the same place! }
- updatefpos:=false;
- p1:=nil;
- filepos:=current_tokenpos;
- again:=false;
- if token=_ID then
- begin
- again:=true;
- { Handle references to self }
- if (idtoken=_SELF) and
- not(block_type in [bt_const,bt_type,bt_const_type,bt_var_type]) and
- assigned(current_structdef) then
- begin
- p1:=load_self_node;
- consume(_ID);
- again:=true;
- end
- else
- factor_read_id(p1,again);
- if assigned(p1) then
- begin
- { factor_read_id will set the filepos to after the id,
- and in case of _SELF the filepos will already be the
- same as filepos (so setting it again doesn't hurt). }
- p1.fileinfo:=filepos;
- filepos:=current_tokenpos;
- end;
- { handle post fix operators }
- updatefpos:=postfixoperators(p1,again);
- end
- else
- begin
- updatefpos:=true;
- case token of
- _RETURN :
- begin
- consume(_RETURN);
- if not(token in [_SEMICOLON,_ELSE,_END]) then
- p1 := cexitnode.create(comp_expr(true,false))
- else
- p1 := cexitnode.create(nil);
- end;
- _INHERITED :
- begin
- again:=true;
- consume(_INHERITED);
- if assigned(current_procinfo) and
- assigned(current_structdef) and
- (current_structdef.typ=objectdef) then
- begin
- { for record helpers in mode Delphi "inherited" is not
- allowed }
- if is_objectpascal_helper(current_structdef) and
- (m_delphi in current_settings.modeswitches) and
- is_record(tobjectdef(current_structdef).extendeddef) then
- Message(parser_e_inherited_not_in_record);
- hclassdef:=tobjectdef(current_structdef).childof;
- { Objective-C categories *replace* methods in the class
- they extend, or add methods to it. So calling an
- inherited method always calls the method inherited from
- the parent of the extended class }
- if is_objccategory(current_structdef) then
- hclassdef:=hclassdef.childof;
- { if inherited; only then we need the method with
- the same name }
- if token <> _ID then
- begin
- hs:=current_procinfo.procdef.procsym.name;
- hsorg:=current_procinfo.procdef.procsym.realname;
- anon_inherited:=true;
- { For message methods we need to search using the message
- number or string }
- pd:=tprocdef(tprocsym(current_procinfo.procdef.procsym).ProcdefList[0]);
- srdef:=nil;
- if (po_msgint in pd.procoptions) then
- searchsym_in_class_by_msgint(hclassdef,pd.messageinf.i,srdef,srsym,srsymtable)
- else
- if (po_msgstr in pd.procoptions) then
- searchsym_in_class_by_msgstr(hclassdef,pd.messageinf.str^,srsym,srsymtable)
- else
- { helpers have their own ways of dealing with inherited }
- if is_objectpascal_helper(current_structdef) then
- searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
- else
- searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
- end
- else
- begin
- hs:=pattern;
- hsorg:=orgpattern;
- consume(_ID);
- anon_inherited:=false;
- { helpers have their own ways of dealing with inherited }
- if is_objectpascal_helper(current_structdef) then
- searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
- else
- searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
- end;
- if assigned(srsym) then
- begin
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- { load the procdef from the inherited class and
- not from self }
- case srsym.typ of
- procsym:
- begin
- if is_objectpascal_helper(current_structdef) then
- begin
- { for a helper load the procdef either from the
- extended type, from the parent helper or from
- the extended type of the parent helper
- depending on the def the found symbol belongs
- to }
- if (srsym.Owner.defowner.typ=objectdef) and
- is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then
- if current_structdef.is_related(tdef(srsym.Owner.defowner)) and
- assigned(tobjectdef(current_structdef).childof) then
- hdef:=tobjectdef(current_structdef).childof
- else
- hdef:=tobjectdef(srsym.Owner.defowner).extendeddef
- else
- hdef:=tdef(srsym.Owner.defowner);
- end
- else
- hdef:=hclassdef;
- if (po_classmethod in current_procinfo.procdef.procoptions) or
- (po_staticmethod in current_procinfo.procdef.procoptions) then
- hdef:=tclassrefdef.create(hdef);
- p1:=ctypenode.create(hdef);
- { we need to allow helpers here }
- ttypenode(p1).helperallowed:=true;
- end;
- propertysym:
- ;
- else
- begin
- Message(parser_e_methode_id_expected);
- p1:=cerrornode.create;
- end;
- end;
- do_member_read(hclassdef,getaddr,srsym,p1,again,[cnf_inherited,cnf_anon_inherited]);
- end
- else
- begin
- if anon_inherited then
- begin
- { For message methods we need to call DefaultHandler }
- if (po_msgint in pd.procoptions) or
- (po_msgstr in pd.procoptions) then
- begin
- searchsym_in_class(hclassdef,hclassdef,'DEFAULTHANDLER',srsym,srsymtable,true);
- if not assigned(srsym) or
- (srsym.typ<>procsym) then
- internalerror(200303171);
- p1:=nil;
- do_proc_call(srsym,srsym.owner,hclassdef,false,again,p1,[]);
- end
- else
- begin
- { we need to ignore the inherited; }
- p1:=cnothingnode.create;
- end;
- end
- else
- begin
- Message1(sym_e_id_no_member,hsorg);
- p1:=cerrornode.create;
- end;
- again:=false;
- end;
- { turn auto inheriting off }
- anon_inherited:=false;
- end
- else
- begin
- { in case of records we use a more clear error message }
- if assigned(current_structdef) and
- (current_structdef.typ=recorddef) then
- Message(parser_e_inherited_not_in_record)
- else
- Message(parser_e_generic_methods_only_in_methods);
- again:=false;
- p1:=cerrornode.create;
- end;
- postfixoperators(p1,again);
- end;
- _INTCONST :
- begin
- {Try first wether the value fits in an int64.}
- val(pattern,ic,code);
- if code=0 then
- begin
- consume(_INTCONST);
- int_to_type(ic,hdef);
- p1:=cordconstnode.create(ic,hdef,true);
- end
- else
- begin
- { try qword next }
- val(pattern,qc,code);
- if code=0 then
- begin
- consume(_INTCONST);
- int_to_type(qc,hdef);
- p1:=cordconstnode.create(qc,hdef,true);
- end;
- end;
- if code<>0 then
- begin
- { finally float }
- val(pattern,d,code);
- if code<>0 then
- begin
- Message(parser_e_invalid_integer);
- consume(_INTCONST);
- l:=1;
- p1:=cordconstnode.create(l,sinttype,true);
- end
- else
- begin
- consume(_INTCONST);
- p1:=crealconstnode.create(d,pbestrealtype^);
- end;
- end
- else
- { the necessary range checking has already been done by val }
- tordconstnode(p1).rangecheck:=false;
- end;
- _REALNUMBER :
- begin
- val(pattern,d,code);
- if code<>0 then
- begin
- Message(parser_e_error_in_real);
- d:=1.0;
- end;
- consume(_REALNUMBER);
- {$ifdef FPC_REAL2REAL_FIXED}
- if current_settings.fputype=fpu_none then
- Message(parser_e_unsupported_real);
- if (current_settings.minfpconstprec=s32real) and
- (d = single(d)) then
- p1:=crealconstnode.create(d,s32floattype)
- else if (current_settings.minfpconstprec=s64real) and
- (d = double(d)) then
- p1:=crealconstnode.create(d,s64floattype)
- else
- {$endif FPC_REAL2REAL_FIXED}
- p1:=crealconstnode.create(d,pbestrealtype^);
- {$ifdef FPC_HAS_STR_CURRENCY}
- val(pattern,cur,code);
- if code=0 then
- trealconstnode(p1).value_currency:=cur;
- {$endif FPC_HAS_STR_CURRENCY}
- end;
- _STRING :
- begin
- string_dec(hdef,true);
- { STRING can be also a type cast }
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- p1:=ctypeconvnode.create_explicit(p1,hdef);
- { handle postfix operators here e.g. string(a)[10] }
- again:=true;
- postfixoperators(p1,again);
- end
- else
- p1:=ctypenode.create(hdef);
- end;
- _FILE :
- begin
- hdef:=cfiletype;
- consume(_FILE);
- { FILE can be also a type cast }
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- p1:=ctypeconvnode.create_explicit(p1,hdef);
- { handle postfix operators here e.g. string(a)[10] }
- again:=true;
- postfixoperators(p1,again);
- end
- else
- begin
- p1:=ctypenode.create(hdef);
- end;
- end;
- _CSTRING :
- begin
- p1:=cstringconstnode.createpchar(ansistring2pchar(cstringpattern),length(cstringpattern));
- consume(_CSTRING);
- end;
- _CCHAR :
- begin
- p1:=cordconstnode.create(ord(pattern[1]),cchartype,true);
- consume(_CCHAR);
- end;
- _CWSTRING:
- begin
- p1:=cstringconstnode.createwstr(patternw);
- consume(_CWSTRING);
- end;
- _CWCHAR:
- begin
- p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
- consume(_CWCHAR);
- end;
- _KLAMMERAFFE :
- begin
- consume(_KLAMMERAFFE);
- got_addrn:=true;
- { support both @<x> and @(<x>) }
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=factor(true,false);
- if token in [_CARET,_POINT,_LECKKLAMMER] then
- begin
- again:=true;
- postfixoperators(p1,again);
- end
- else
- consume(_RKLAMMER);
- end
- else
- p1:=factor(true,false);
- if token in [_CARET,_POINT,_LECKKLAMMER] then
- begin
- again:=true;
- postfixoperators(p1,again);
- end;
- got_addrn:=false;
- p1:=caddrnode.create(p1);
- p1.fileinfo:=filepos;
- if cs_typed_addresses in current_settings.localswitches then
- include(p1.flags,nf_typedaddr);
- { Store the procvar that we are expecting, the
- addrn will use the information to find the correct
- procdef or it will return an error }
- if assigned(getprocvardef) and
- (taddrnode(p1).left.nodetype = loadn) then
- taddrnode(p1).getprocvardef:=getprocvardef;
- end;
- _LKLAMMER :
- begin
- consume(_LKLAMMER);
- p1:=comp_expr(true,false);
- consume(_RKLAMMER);
- { it's not a good solution }
- { but (a+b)^ makes some problems }
- if token in [_CARET,_POINT,_LECKKLAMMER] then
- begin
- again:=true;
- postfixoperators(p1,again);
- end;
- end;
- _LECKKLAMMER :
- begin
- consume(_LECKKLAMMER);
- p1:=factor_read_set;
- consume(_RECKKLAMMER);
- end;
- _PLUS :
- begin
- consume(_PLUS);
- p1:=factor(false,false);
- p1:=cunaryplusnode.create(p1);
- end;
- _MINUS :
- begin
- consume(_MINUS);
- if (token = _INTCONST) and not(m_isolike_unary_minus in current_settings.modeswitches) then
- begin
- { ugly hack, but necessary to be able to parse }
- { -9223372036854775808 as int64 (JM) }
- pattern := '-'+pattern;
- p1:=sub_expr(oppower,false,false);
- { -1 ** 4 should be - (1 ** 4) and not
- (-1) ** 4
- This was the reason of tw0869.pp test failure PM }
- if p1.nodetype=starstarn then
- begin
- if tbinarynode(p1).left.nodetype=ordconstn then
- begin
- tordconstnode(tbinarynode(p1).left).value:=-tordconstnode(tbinarynode(p1).left).value;
- p1:=cunaryminusnode.create(p1);
- end
- else if tbinarynode(p1).left.nodetype=realconstn then
- begin
- trealconstnode(tbinarynode(p1).left).value_real:=-trealconstnode(tbinarynode(p1).left).value_real;
- trealconstnode(tbinarynode(p1).left).value_currency:=-trealconstnode(tbinarynode(p1).left).value_currency;
- p1:=cunaryminusnode.create(p1);
- end
- else
- internalerror(20021029);
- end;
- end
- else
- begin
- if m_isolike_unary_minus in current_settings.modeswitches then
- p1:=sub_expr(opmultiply,false,false)
- else
- p1:=sub_expr(oppower,false,false);
- p1:=cunaryminusnode.create(p1);
- end;
- end;
- _OP_NOT :
- begin
- consume(_OP_NOT);
- p1:=factor(false,false);
- p1:=cnotnode.create(p1);
- end;
- _TRUE :
- begin
- consume(_TRUE);
- p1:=cordconstnode.create(1,pasbool8type,false);
- end;
- _FALSE :
- begin
- consume(_FALSE);
- p1:=cordconstnode.create(0,pasbool8type,false);
- end;
- _NIL :
- begin
- consume(_NIL);
- p1:=cnilnode.create;
- { It's really ugly code nil^, but delphi allows it }
- if token in [_CARET] then
- begin
- again:=true;
- postfixoperators(p1,again);
- end;
- end;
- _OBJCPROTOCOL:
- begin
- { The @protocol keyword is used in two ways in Objective-C:
- 1) to declare protocols (~ Object Pascal interfaces)
- 2) to obtain the metaclass (~ Object Pascal) "class of")
- of a declared protocol
- This code is for handling the second case. Because of 1),
- we cannot simply use a system unit symbol.
- }
- consume(_OBJCPROTOCOL);
- consume(_LKLAMMER);
- p1:=factor(false,false);
- consume(_RKLAMMER);
- p1:=cinlinenode.create(in_objc_protocol_x,false,p1);
- end;
- else
- begin
- Message(parser_e_illegal_expression);
- p1:=cerrornode.create;
- { recover }
- consume(token);
- end;
- end;
- end;
- { generate error node if no node is created }
- if not assigned(p1) then
- begin
- {$ifdef EXTDEBUG}
- Comment(V_Warning,'factor: p1=nil');
- {$endif}
- p1:=cerrornode.create;
- updatefpos:=true;
- end;
- { get the resultdef for the node }
- if (not assigned(p1.resultdef)) then
- begin
- do_typecheckpass_changed(p1,nodechanged);
- updatefpos:=updatefpos or nodechanged;
- end;
- if assigned(p1) and
- updatefpos then
- p1.fileinfo:=filepos;
- factor:=p1;
- end;
- {$maxfpuregisters default}
- {****************************************************************************
- Sub_Expr
- ****************************************************************************}
- const
- { Warning these stay be ordered !! }
- operator_levels:array[Toperator_precedence] of set of NOTOKEN..last_operator=
- ([_LT,_LTE,_GT,_GTE,_EQ,_NE,_OP_IN],
- [_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR],
- [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,
- _OP_AS,_OP_IS,_OP_AND,_AMPERSAND,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR],
- [_STARSTAR] );
- function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean):tnode;
- {Reads a subexpression while the operators are of the current precedence
- level, or any higher level. Replaces the old term, simpl_expr and
- simpl2_expr.}
- var
- p1,p2 : tnode;
- oldt : Ttoken;
- filepos : tfileposinfo;
- begin
- if pred_level=highest_precedence then
- p1:=factor(false,typeonly)
- else
- p1:=sub_expr(succ(pred_level),true,typeonly);
- repeat
- if (token in [NOTOKEN..last_operator]) and
- (token in operator_levels[pred_level]) and
- ((token<>_EQ) or accept_equal) then
- begin
- oldt:=token;
- filepos:=current_tokenpos;
- consume(token);
- if pred_level=highest_precedence then
- p2:=factor(false,false)
- else
- p2:=sub_expr(succ(pred_level),true,typeonly);
- case oldt of
- _PLUS :
- p1:=caddnode.create(addn,p1,p2);
- _MINUS :
- p1:=caddnode.create(subn,p1,p2);
- _STAR :
- p1:=caddnode.create(muln,p1,p2);
- _SLASH :
- p1:=caddnode.create(slashn,p1,p2);
- _EQ:
- p1:=caddnode.create(equaln,p1,p2);
- _GT :
- p1:=caddnode.create(gtn,p1,p2);
- _LT :
- p1:=caddnode.create(ltn,p1,p2);
- _GTE :
- p1:=caddnode.create(gten,p1,p2);
- _LTE :
- p1:=caddnode.create(lten,p1,p2);
- _SYMDIF :
- p1:=caddnode.create(symdifn,p1,p2);
- _STARSTAR :
- p1:=caddnode.create(starstarn,p1,p2);
- _OP_AS :
- p1:=casnode.create(p1,p2);
- _OP_IN :
- p1:=cinnode.create(p1,p2);
- _OP_IS :
- p1:=cisnode.create(p1,p2);
- _OP_OR,
- _PIPE {macpas only} :
- begin
- p1:=caddnode.create(orn,p1,p2);
- if (oldt = _PIPE) then
- include(p1.flags,nf_short_bool);
- end;
- _OP_AND,
- _AMPERSAND {macpas only} :
- begin
- p1:=caddnode.create(andn,p1,p2);
- if (oldt = _AMPERSAND) then
- include(p1.flags,nf_short_bool);
- end;
- _OP_DIV :
- p1:=cmoddivnode.create(divn,p1,p2);
- _OP_NOT :
- p1:=cnotnode.create(p1);
- _OP_MOD :
- p1:=cmoddivnode.create(modn,p1,p2);
- _OP_SHL :
- p1:=cshlshrnode.create(shln,p1,p2);
- _OP_SHR :
- p1:=cshlshrnode.create(shrn,p1,p2);
- _OP_XOR :
- p1:=caddnode.create(xorn,p1,p2);
- _ASSIGNMENT :
- p1:=cassignmentnode.create(p1,p2);
- _NE :
- p1:=caddnode.create(unequaln,p1,p2);
- end;
- p1.fileinfo:=filepos;
- end
- else
- break;
- until false;
- sub_expr:=p1;
- end;
- function comp_expr(accept_equal,typeonly:boolean):tnode;
- var
- oldafterassignment : boolean;
- p1 : tnode;
- begin
- oldafterassignment:=afterassignment;
- afterassignment:=true;
- p1:=sub_expr(opcompare,accept_equal,typeonly);
- { get the resultdef for this expression }
- if not assigned(p1.resultdef) then
- do_typecheckpass(p1);
- afterassignment:=oldafterassignment;
- comp_expr:=p1;
- end;
- function expr(dotypecheck : boolean) : tnode;
- var
- p1,p2 : tnode;
- filepos : tfileposinfo;
- oldafterassignment,
- updatefpos : boolean;
- begin
- oldafterassignment:=afterassignment;
- p1:=sub_expr(opcompare,true,false);
- { get the resultdef for this expression }
- if not assigned(p1.resultdef) and
- dotypecheck then
- do_typecheckpass(p1);
- filepos:=current_tokenpos;
- if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
- afterassignment:=true;
- updatefpos:=true;
- case token of
- _POINTPOINT :
- begin
- consume(_POINTPOINT);
- p2:=sub_expr(opcompare,true,false);
- p1:=crangenode.create(p1,p2);
- end;
- _ASSIGNMENT :
- begin
- consume(_ASSIGNMENT);
- if (p1.resultdef.typ=procvardef) then
- getprocvardef:=tprocvardef(p1.resultdef);
- p2:=sub_expr(opcompare,true,false);
- if assigned(getprocvardef) then
- handle_procvar(getprocvardef,p2);
- getprocvardef:=nil;
- p1:=cassignmentnode.create(p1,p2);
- end;
- _PLUSASN :
- begin
- consume(_PLUSASN);
- p2:=sub_expr(opcompare,true,false);
- p1:=gen_c_style_operator(addn,p1,p2);
- end;
- _MINUSASN :
- begin
- consume(_MINUSASN);
- p2:=sub_expr(opcompare,true,false);
- p1:=gen_c_style_operator(subn,p1,p2);
- end;
- _STARASN :
- begin
- consume(_STARASN );
- p2:=sub_expr(opcompare,true,false);
- p1:=gen_c_style_operator(muln,p1,p2);
- end;
- _SLASHASN :
- begin
- consume(_SLASHASN );
- p2:=sub_expr(opcompare,true,false);
- p1:=gen_c_style_operator(slashn,p1,p2);
- end;
- else
- updatefpos:=false;
- end;
- { get the resultdef for this expression }
- if not assigned(p1.resultdef) and
- dotypecheck then
- do_typecheckpass(p1);
- afterassignment:=oldafterassignment;
- if updatefpos then
- p1.fileinfo:=filepos;
- expr:=p1;
- end;
- function get_intconst:TConstExprInt;
- {Reads an expression, tries to evalute it and check if it is an integer
- constant. Then the constant is returned.}
- var
- p:tnode;
- begin
- result:=0;
- p:=comp_expr(true,false);
- if not codegenerror then
- begin
- if (p.nodetype<>ordconstn) or
- not(is_integer(p.resultdef)) then
- Message(parser_e_illegal_expression)
- else
- result:=tordconstnode(p).value;
- end;
- p.free;
- end;
- function get_stringconst:string;
- {Reads an expression, tries to evaluate it and checks if it is a string
- constant. Then the constant is returned.}
- var
- p:tnode;
- begin
- get_stringconst:='';
- p:=comp_expr(true,false);
- if p.nodetype<>stringconstn then
- begin
- if (p.nodetype=ordconstn) and is_char(p.resultdef) then
- get_stringconst:=char(int64(tordconstnode(p).value))
- else
- Message(parser_e_illegal_expression);
- end
- else
- get_stringconst:=strpas(tstringconstnode(p).value_str);
- p.free;
- end;
- end.
|