123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858 |
- {
- 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;
- { Does some postprocessing for a generic type (especially when nested types
- of the specialization are used) }
- procedure post_comp_expr_gendef(var def: tdef);
- implementation
- uses
- { common }
- cutils,
- { global }
- verbose,
- systems,widestr,
- { symtable }
- symconst,symtable,symsym,symcpu,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,pgenutil,procinfo,cpuinfo
- ;
- function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean;factornode:tnode):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;
- if tordconstnode(p).value>255 then
- begin
- { longstring is currently unsupported (CEC)! }
- { t:=cstringdef.createlong(tordconstnode(p).value))}
- Message(parser_e_invalid_string_size);
- tordconstnode(p).value:=255;
- def:=cstringdef.createshort(int64(tordconstnode(p).value));
- end
- else
- if tordconstnode(p).value<>255 then
- def:=cstringdef.createshort(int64(tordconstnode(p).value));
- consume(_RECKKLAMMER);
- end;
- p.free;
- end
- else
- begin
- if cs_refcountedstrings in current_settings.localswitches then
- begin
- if m_default_unicodestring in current_settings.modeswitches then
- def:=cunicodestringtype
- else
- def:=getansistringdef
- end
- 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:=getpointerdef(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;
- def : tdef;
- exit_procinfo: tprocinfo;
- 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
- statement_syssym:=nil;
- 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
- (current_procinfo.procdef.proctypeoption in [potype_constructor,potype_destructor]) 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
- { non local exit ? }
- if current_procinfo.procdef.procsym.name<>pattern then
- begin
- exit_procinfo:=current_procinfo.parent;
- while assigned(exit_procinfo) do
- begin
- if exit_procinfo.procdef.procsym.name=pattern then
- break;
- exit_procinfo:=exit_procinfo.parent;
- end;
- if assigned(exit_procinfo) then
- begin
- if not(assigned(exit_procinfo.nestedexitlabel)) then
- begin
- include(current_procinfo.flags,pi_has_nested_exit);
- exclude(current_procinfo.procdef.procoptions,po_inline);
- exit_procinfo.nestedexitlabel:=clabelsym.create('$nestedexit');
- { the compiler is responsible to define this label }
- exit_procinfo.nestedexitlabel.defined:=true;
- exit_procinfo.nestedexitlabel.used:=true;
- exit_procinfo.nestedexitlabel.jumpbuf:=clocalvarsym.create('LABEL$_'+exit_procinfo.nestedexitlabel.name,vs_value,rec_jmp_buf,[]);
- exit_procinfo.procdef.localst.insert(exit_procinfo.nestedexitlabel);
- exit_procinfo.procdef.localst.insert(exit_procinfo.nestedexitlabel.jumpbuf);
- end;
- statement_syssym:=cgotonode.create(exit_procinfo.nestedexitlabel);
- tgotonode(statement_syssym).labelsym:=exit_procinfo.nestedexitlabel;
- end
- else
- Message(parser_e_macpas_exit_wrong_param);
- end;
- consume(_ID);
- consume(_RKLAMMER);
- p1:=nil;
- end
- end
- else
- p1:=nil;
- if not assigned(statement_syssym) then
- 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
- not(is_java_class_or_interface(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)
- )) or
- { keep the function call if it is a type parameter to avoid arithmetic errors due to constant folding }
- (p1.resultdef.typ=undefineddef) 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_aligned_x,
- in_unaligned_x :
- begin
- err:=false;
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr(true,false);
- p2:=ccallparanode.create(p1,nil);
- p2:=geninlinenode(l,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
- if p1.resultdef.typ<>undefineddef then
- 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
- if target_info.system in systems_managed_vm then
- message(parser_e_feature_unsupported_for_vm);
- 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;
- *)
- in_default_x:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- def:=nil;
- single_type(def,[stoAllowSpecialization]);
- statement_syssym:=cerrornode.create;
- if def<>generrordef then
- { "type expected" error is already done by single_type }
- if def.typ=forwarddef then
- Message1(type_e_type_is_not_completly_defined,tforwarddef(def).tosymname^)
- else
- begin
- statement_syssym.free;
- statement_syssym:=geninlinenode(in_default_x,false,ctypenode.create(def));
- end;
- { consume the right bracket here for a nicer error position }
- consume(_RKLAMMER);
- end;
- in_setstring_x_y_z:
- begin
- statement_syssym := inline_setstring;
- end;
- else
- internalerror(15);
- end;
- in_args:=prev_in_args;
- end;
- function maybe_load_methodpointer(st:TSymtable;var p1:tnode):boolean;
- var
- pd: tprocdef;
- 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
- { Escape nested procedures }
- if assigned(current_procinfo) then
- begin
- pd:=current_procinfo.get_normal_proc.procdef;
- { We are calling from the static class method which has no self node }
- if assigned(pd) and pd.no_self_node then
- if st.symtabletype=recordsymtable then
- p1:=ctypenode.create(pd.struct)
- else
- p1:=cloadvmtaddrnode.create(ctypenode.create(pd.struct))
- else
- p1:=load_self_node;
- end
- 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)) and
- not(token in [_CARET,_POINT,_LKLAMMER]) 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(tloadnode(p2).loadnodeflags,loadnf_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;
- { 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 propsym.getpropaccesslist(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 propsym.getpropaccesslist(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);
- { catch expressions like "(propx):=1;" }
- include(p1.flags,nf_no_lvalue);
- 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);
- include(p1.flags,nf_no_lvalue);
- 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) then
- begin
- if 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);
- { in Java, constructors are not automatically inherited
- -> calling a constructor from a parent type will create
- an instance of that parent type! }
- if is_javaclass(structh) and
- (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
- (tcallnode(p1).procdefinition.owner.defowner<>find_real_class_definition(tobjectdef(structh),false)) then
- Message(parser_e_java_no_inherited_constructor);
- { Provide a warning if we try to create an instance of a
- abstract class using the type name of that class. We
- must not provide a warning if we use a "class of"
- variable of that type though as we don't know the
- type of the class }
- if (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) and
- (oo_is_abstract in structh.objectoptions) and
- assigned(tcallnode(p1).methodpointer) and
- (tcallnode(p1).methodpointer.nodetype=loadvmtaddrn) then
- Message1(type_w_instance_abstract_class,structh.RttiName);
- end;
- 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.get_normal_proc.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) or
- is_javaclass(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;
- function handle_factor_typenode(hdef:tdef;getaddr:boolean;var again:boolean;sym:tsym;typeonly:boolean):tnode;
- var
- srsym : tsym;
- srsymtable : tsymtable;
- begin
- if sym=nil then
- sym:=hdef.typesym;
- { allow Ordinal(Value) for type declarations since it
- can be an enummeration declaration or a set lke:
- (OrdinalType(const1)..OrdinalType(const2) }
- if (not typeonly or is_ordinal(hdef)) and
- try_to_consume(_LKLAMMER) then
- begin
- result:=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
- result:=ctypeconvnode.create_explicit(result,hdef);
- end
- { not LKLAMMER }
- else 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
- def_is_related(current_structdef,hdef) then
- begin
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- { search also in inherited methods }
- searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,[ssf_search_helper]);
- if assigned(srsym) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(tabstractrecorddef(hdef),false,srsym,result,again,[]);
- end
- else
- begin
- { handles:
- * @TObject.Load
- * static methods and variables }
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- { 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,result,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) or
- { Java interfaces also can have loadvmtaddrnodes,
- e.g. for expressions such as JLClass(intftype) }
- is_java_class_or_interface(hdef) then
- begin
- if getaddr and (token=_POINT) and
- not is_javainterface(hdef) then
- begin
- consume(_POINT);
- { allows @Object.Method }
- { also allows static methods and variables }
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- { 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);
- { in case of @Object.Method1.Method2, we have to call
- Method1 -> create a loadvmtaddr node as self instead of
- a typen (the typenode would be changed to self of the
- current method in case Method1 is a constructor, see
- mantis #24844) }
- if not(block_type in [bt_type,bt_const_type,bt_var_type]) and
- (srsym.typ=procsym) and
- (token in [_CARET,_POINT]) then
- result:=cloadvmtaddrnode.create(result);
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,result,again,[]);
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- consume(_ID);
- end;
- end
- else
- begin
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- { 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
- result:=cloadvmtaddrnode.create(result);
- end;
- end
- else
- begin
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- end;
- end;
- end;
- {****************************************************************************
- Factor
- ****************************************************************************}
- function real_const_node_from_pattern(s:string):tnode;
- var
- d : bestreal;
- code : integer;
- cur : currency;
- begin
- val(s,d,code);
- if code<>0 then
- begin
- Message(parser_e_error_in_real);
- d:=1.0;
- end;
- {$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
- result:=crealconstnode.create(d,s32floattype)
- else if (current_settings.minfpconstprec=s64real) and
- (d = double(d)) then
- result:=crealconstnode.create(d,s64floattype)
- else
- {$endif FPC_REAL2REAL_FIXED}
- result:=crealconstnode.create(d,pbestrealtype^);
- {$ifdef FPC_HAS_STR_CURRENCY}
- val(pattern,cur,code);
- if code=0 then
- trealconstnode(result).value_currency:=cur;
- {$endif FPC_HAS_STR_CURRENCY}
- end;
- {---------------------------------------------
- PostFixOperators
- ---------------------------------------------}
- { returns whether or not p1 has been changed }
- function postfixoperators(var p1:tnode;var again:boolean;getaddr: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;
- function parse_array_constructor(arrdef:tarraydef): tnode;
- var
- newstatement,assstatement:tstatementnode;
- arrnode:ttempcreatenode;
- temp2:ttempcreatenode;
- assnode:tnode;
- paracount:integer;
- begin
- result:=internalstatements(newstatement);
- { create temp for result }
- arrnode:=ctempcreatenode.create(arrdef,arrdef.size,tt_persistent,true);
- addstatement(newstatement,arrnode);
- paracount:=0;
- { check arguments and create an assignment calls }
- if try_to_consume(_LKLAMMER) then
- begin
- assnode:=internalstatements(assstatement);
- repeat
- { arr[i] := param_i }
- addstatement(assstatement,
- cassignmentnode.create(
- cvecnode.create(
- ctemprefnode.create(arrnode),
- cordconstnode.create(paracount,arrdef.rangedef,false)),
- comp_expr(true,false)));
- inc(paracount);
- until not try_to_consume(_COMMA);
- consume(_RKLAMMER);
- end
- else
- assnode:=nil;
- { get temp for array of lengths }
- temp2:=ctempcreatenode.create(sinttype,sinttype.size,tt_persistent,false);
- addstatement(newstatement,temp2);
- { one dimensional }
- addstatement(newstatement,cassignmentnode.create(
- ctemprefnode.create_offset(temp2,0),
- cordconstnode.create
- (paracount,s32inttype,true)));
- { create call to fpc_dynarr_setlength }
- addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
- ccallparanode.create(caddrnode.create_internal
- (ctemprefnode.create(temp2)),
- ccallparanode.create(cordconstnode.create
- (1,s32inttype,true),
- ccallparanode.create(caddrnode.create_internal
- (crttinode.create(tstoreddef(arrdef),initrtti,rdt_normal)),
- ccallparanode.create(
- ctypeconvnode.create_internal(
- ctemprefnode.create(arrnode),voidpointertype),
- nil))))
- ));
- { add assignment statememnts }
- addstatement(newstatement,ctempdeletenode.create(temp2));
- if assigned(assnode) then
- addstatement(newstatement,assnode);
- { 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(arrnode));
- addstatement(newstatement,ctemprefnode.create(arrnode));
- end;
- function try_type_helper(var node:tnode;def:tdef):boolean;
- var
- srsym : tsym;
- srsymtable : tsymtable;
- n : tnode;
- newstatement : tstatementnode;
- temp : ttempcreatenode;
- extdef : tdef;
- begin
- result:=false;
- if (token=_ID) and (block_type in [bt_body,bt_general,bt_except]) then
- begin
- if not assigned(def) then
- if node.nodetype=addrn then
- { always use the pointer type for addr nodes as otherwise
- we'll have an anonymous pointertype with no name }
- def:=voidpointertype
- else
- def:=node.resultdef;
- result:=search_objectpascal_helper(def,nil,pattern,srsym,srsymtable);
- if result then
- begin
- if not (srsymtable.symtabletype=objectsymtable) or
- not is_objectpascal_helper(tdef(srsymtable.defowner)) then
- internalerror(2013011401);
- { convert const node to temp node of the extended type }
- if node.nodetype in (nodetype_const+[niln,addrn]) then
- begin
- extdef:=tobjectdef(srsymtable.defowner).extendeddef;
- newstatement:=nil;
- n:=internalstatements(newstatement);
- temp:=ctempcreatenode.create(extdef,extdef.size,tt_persistent,false);
- addstatement(newstatement,temp);
- addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),node));
- addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
- addstatement(newstatement,ctemprefnode.create(temp));
- node:=n;
- do_typecheckpass(node)
- end;
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- do_member_read(nil,getaddr,srsym,node,again,[]);
- end;
- end;
- 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;
- found,
- haderror,
- nodechanged : boolean;
- calltype: tdispcalltype;
- valstr,expstr : string;
- intval : qword;
- code : integer;
- strdef : tdef;
- label
- skipreckklammercheck,
- skippointdefcheck;
- 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;
- { iso file buf access? }
- if (m_iso in current_settings.modeswitches) and
- (p1.resultdef.typ=filedef) then
- begin
- case tfiledef(p1.resultdef).filetyp of
- ft_text:
- begin
- p1:=cderefnode.create(ccallnode.createintern('fpc_getbuf_text',ccallparanode.create(p1,nil)));
- typecheckpass(p1);
- end;
- ft_typed:
- begin
- p1:=cderefnode.create(ctypeconvnode.create_internal(ccallnode.createintern('fpc_getbuf_typedfile',ccallparanode.create(p1,nil)),
- getpointerdef(tfiledef(p1.resultdef).typedfiledef)));
- typecheckpass(p1);
- end;
- end;
- end
- else 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) or
- is_javaclass(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/msdos Mem[] }
- if (target_info.system in [system_i386_go32v2,system_i386_watcom,system_i8086_msdos]) 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 defined(i8086)}
- consume(_COLON);
- inserttypeconv(p2,u16inttype);
- inserttypeconv_internal(p2,u32inttype);
- p3:=cshlshrnode.create(shln,p2,cordconstnode.create($10,s16inttype,false));
- p2:=comp_expr(true,false);
- inserttypeconv(p2,u16inttype);
- inserttypeconv_internal(p2,u32inttype);
- p2:=caddnode.create(addn,p2,p3);
- case tloadnode(p1).symtableentry.name of
- 'MEM': p2:=ctypeconvnode.create_internal(p2,bytefarpointertype);
- 'MEMW': p2:=ctypeconvnode.create_internal(p2,wordfarpointertype);
- 'MEML': p2:=ctypeconvnode.create_internal(p2,longintfarpointertype);
- else
- internalerror(2013053102);
- end;
- p1:=cderefnode.create(p2);
- {$elseif defined(i386)}
- 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;
- {$else}
- internalerror(2013053101);
- {$endif}
- 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);
- if (p1.nodetype=ordconstn) and
- not is_boolean(p1.resultdef) and
- not is_enum(p1.resultdef) then
- begin
- { type helpers are checked first }
- if (token=_ID) and try_type_helper(p1,nil) then
- goto skippointdefcheck;
- { only an "e" or "E" can follow an intconst with a ".", the
- other case (another intconst) is handled by the scanner }
- if (token=_ID) and (pattern[1]='E') then
- begin
- haderror:=false;
- if length(pattern)>1 then
- begin
- expstr:=copy(pattern,2,length(pattern)-1);
- val(expstr,intval,code);
- if code<>0 then
- haderror:=true;
- end
- else
- expstr:='';
- consume(token);
- if tordconstnode(p1).value.signed then
- str(tordconstnode(p1).value.svalue,valstr)
- else
- str(tordconstnode(p1).value.uvalue,valstr);
- valstr:=valstr+'.0E';
- if expstr='' then
- case token of
- _MINUS:
- begin
- consume(token);
- if token=_INTCONST then
- begin
- valstr:=valstr+'-'+pattern;
- consume(token);
- end
- else
- haderror:=true;
- end;
- _PLUS:
- begin
- consume(token);
- if token=_INTCONST then
- begin
- valstr:=valstr+pattern;
- consume(token);
- end
- else
- haderror:=true;
- end;
- _INTCONST:
- begin
- valstr:=valstr+pattern;
- consume(_INTCONST);
- end;
- else
- haderror:=true;
- end
- else
- valstr:=valstr+expstr;
- if haderror then
- begin
- Message(parser_e_error_in_real);
- p2:=cerrornode.create;
- end
- else
- p2:=real_const_node_from_pattern(valstr);
- p1.free;
- p1:=p2;
- again:=false;
- goto skippointdefcheck;
- end
- else
- begin
- { just convert the ordconst to a realconst }
- p2:=crealconstnode.create(tordconstnode(p1).value,pbestrealtype^);
- p1.free;
- p1:=p2;
- again:=false;
- goto skippointdefcheck;
- end;
- end;
- if (p1.nodetype=stringconstn) and (token=_ID) then
- begin
- { the def of a string const is an array }
- case tstringconstnode(p1).cst_type of
- cst_conststring:
- if cs_refcountedstrings in current_settings.localswitches then
- if m_default_unicodestring in current_settings.modeswitches then
- strdef:=cunicodestringtype
- else
- strdef:=cansistringtype
- else
- strdef:=cshortstringtype;
- cst_shortstring:
- strdef:=cshortstringtype;
- cst_ansistring:
- { use getansistringdef? }
- strdef:=cansistringtype;
- cst_widestring:
- strdef:=cwidestringtype;
- cst_unicodestring:
- strdef:=cunicodestringtype;
- cst_longstring:
- { let's see when someone stumbles upon this...}
- internalerror(201301111);
- else
- internalerror(2013112903);
- end;
- if try_type_helper(p1,strdef) then
- goto skippointdefcheck;
- end;
- { this is skipped if label skippointdefcheck is used }
- 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));
- if assigned(srsym) and (srsym.typ=enumsym) and (p1.nodetype=typen) then
- begin
- p1.destroy;
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- p1:=genenumnode(tenumsym(srsym));
- consume(_ID);
- end
- else
- if not try_type_helper(p1,nil) then
- begin
- p1.destroy;
- Message1(sym_e_id_no_member,orgpattern);
- p1:=cerrornode.create;
- consume(_ID);
- end;
- end;
- end;
- arraydef:
- begin
- if is_dynamic_array(p1.resultdef) then
- begin
- if (token=_ID) and not try_type_helper(p1,nil) then
- begin
- if pattern='CREATE' then
- begin
- consume(_ID);
- p2:=parse_array_constructor(tarraydef(p1.resultdef));
- p1.destroy;
- p1:=p2;
- end
- else
- begin
- Message2(scan_f_syn_expected,'CREATE',pattern);
- p1.destroy;
- p1:=cerrornode.create;
- consume(_ID);
- end;
- end;
- end
- else
- begin
- Message(parser_e_invalid_qualifier);
- p1.destroy;
- p1:=cerrornode.create;
- consume(_ID);
- end;
- 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
- if not try_type_helper(p1,nil) 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;
- 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,[ssf_search_helper]);
- 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,[ssf_search_helper]);
- 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
- if not try_type_helper(p1,nil) then
- 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
- end;
- else
- begin
- found:=try_type_helper(p1,nil);
- if not found then
- begin
- if p1.resultdef.typ<>undefineddef then
- Message(parser_e_invalid_qualifier);
- p1.destroy;
- p1:=cerrornode.create;
- { Error }
- consume(_ID);
- end;
- end;
- end;
- { processing an ordconstnode avoids the resultdef check }
- skippointdefcheck:
- 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;
- 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);
- function findwithsymtable : boolean;
- var
- hp : psymtablestackitem;
- begin
- result:=true;
- hp:=symtablestack.stack;
- while assigned(hp) do
- begin
- if hp^.symtable.symtabletype=withsymtable then
- exit;
- hp:=hp^.next;
- end;
- result:=false;
- end;
- var
- srsym: tsym;
- srsymtable: TSymtable;
- hdef: tdef;
- pd: tprocdef;
- orgstoredpattern,
- storedpattern: string;
- callflags: tcallnodeflags;
- t : ttoken;
- unit_found : boolean;
- tokenpos: tfileposinfo;
- begin
- { allow post fix operators }
- again:=true;
- { preinitalize tokenpos }
- tokenpos:=current_filepos;
- p1:=nil;
- { first check for identifier }
- if token<>_ID then
- begin
- srsym:=generrorsym;
- srsymtable:=nil;
- consume(_ID);
- unit_found:=false;
- 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,true);
- storedpattern:=pattern;
- orgstoredpattern:=orgpattern;
- { store the position of the token before consuming it }
- tokenpos:=current_filepos;
- 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;
- { check hints, but only if it isn't a potential generic symbol;
- that is checked in sub_expr if it isn't a generic }
- if assigned(srsym) and
- not (
- (srsym.typ=typesym) and
- (ttypesym(srsym).typedef.typ in [recorddef,objectdef,arraydef,procvardef,undefineddef]) and
- not (sp_generic_para in srsym.symoptions) and
- (token in [_LT, _LSHARPBRACKET])
- ) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- { if nothing found give error and return errorsym }
- if not assigned(srsym) or
- { is this a generic dummy symbol? }
- ((srsym.typ=typesym) and
- assigned(ttypesym(srsym).typedef) and
- (ttypesym(srsym).typedef.typ=undefineddef) and
- not (sp_generic_para in srsym.symoptions) and
- not (token in [_LT, _LSHARPBRACKET]) and
- not (
- { in non-Delphi modes the generic class' name without a
- "specialization" or "<T>" may be used to identify the
- current class }
- (sp_generic_dummy in srsym.symoptions) and
- assigned(current_structdef) and
- (df_generic in current_structdef.defoptions) and
- not (m_delphi in current_settings.modeswitches) and
- assigned(get_generic_in_hierarchy_by_name(srsym,current_structdef))
- )) and
- { it could be a rename of a generic para }
- { Note: if this generates false positives we'll need to
- include a "basesym" to tsym to track the original
- symbol }
- not (sp_explicitrename in srsym.symoptions) then
- begin
- { if a generic is parsed and when we are inside an with block,
- a symbol might not be defined }
- if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) and
- findwithsymtable then
- begin
- { create dummy symbol, it will be freed later on }
- srsym:=tsym.create(undefinedsym,'$undefinedsym');
- srsymtable:=nil;
- end
- else
- begin
- identifier_not_found(orgstoredpattern,tokenpos);
- srsym:=generrorsym;
- srsymtable:=nil;
- end;
- 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,m_delphi,m_mac,m_iso] * 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 we are accessing a owner procsym from the nested }
- { class we need to call it as a class member }
- if assigned(current_structdef) and
- (((current_structdef<>hdef) and is_owned_by(current_structdef,hdef)) or
- (sp_static in srsym.symoptions)) then
- if srsymtable.symtabletype=recordsymtable then
- p1:=ctypenode.create(hdef)
- else
- p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
- else
- begin
- if assigned(current_procinfo) then
- begin
- pd:=current_procinfo.get_normal_proc.procdef;
- if assigned(pd) and pd.no_self_node then
- p1:=cloadvmtaddrnode.create(ctypenode.create(pd.struct))
- else
- p1:=load_self_node;
- end
- else
- p1:=load_self_node;
- end;
- { 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) or (hdef=colevarianttype)) and
- not(cs_compilesystem in current_settings.moduleswitches) then
- current_module.flags:=current_module.flags or uf_uses_variants;
- p1:=handle_factor_typenode(hdef,getaddr,again,srsym,typeonly);
- 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:=getansistringdef;
- 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
- { if we are accessing a owner procsym from the nested }
- { class we need to call it as a class member }
- if (srsymtable.symtabletype in [ObjectSymtable,recordsymtable]) and
- assigned(current_structdef) and (current_structdef<>hdef) and is_owned_by(current_structdef,hdef) then
- p1:=cloadvmtaddrnode.create(ctypenode.create(hdef));
- { 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 we are accessing a owner procsym from the nested }
- { class or from a static class method we need to call }
- { it as a class member }
- if (assigned(current_structdef) and (current_structdef<>hdef) and is_owned_by(current_structdef,hdef)) or
- (assigned(current_procinfo) and current_procinfo.get_normal_proc.procdef.no_self_node) then
- 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;
- undefinedsym :
- begin
- p1:=cnothingnode.Create;
- p1.resultdef:=cundefineddef.create;
- { clean up previously created dummy symbol }
- srsym.free;
- 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 }
- if assigned(p1) and (p1.nodetype<>errorn) then
- p1.fileinfo:=tokenpos;
- 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;
- lastp:=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;
- function can_load_self_node: boolean;
- begin
- result:=false;
- if (block_type in [bt_const,bt_type,bt_const_type,bt_var_type]) or
- not assigned(current_structdef) or
- not assigned(current_procinfo) then
- exit;
- result:=not current_procinfo.get_normal_proc.procdef.no_self_node;
- end;
- {---------------------------------------------
- Factor (Main)
- ---------------------------------------------}
- var
- l : longint;
- ic : int64;
- qc : qword;
- p1 : tnode;
- code : integer;
- srsym : tsym;
- srsymtable : TSymtable;
- pd : tprocdef;
- hclassdef : tobjectdef;
- d : bestreal;
- hs,hsorg : string;
- hdef : tdef;
- filepos : tfileposinfo;
- callflags : tcallnodeflags;
- idstr : tidstring;
- dopostfix,
- 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! }
- dopostfix:=true;
- updatefpos:=false;
- p1:=nil;
- filepos:=current_tokenpos;
- again:=false;
- pd:=nil;
- if token=_ID then
- begin
- again:=true;
- { Handle references to self }
- if (idtoken=_SELF) and can_load_self_node 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 }
- if (m_delphi in current_settings.modeswitches) and
- (block_type=bt_body) and
- (token in [_LT,_LSHARPBRACKET]) then
- begin
- if p1.nodetype=typen then
- idstr:=ttypenode(p1).typesym.name
- else
- if (p1.nodetype=loadvmtaddrn) and
- (tloadvmtaddrnode(p1).left.nodetype=typen) then
- idstr:=ttypenode(tloadvmtaddrnode(p1).left).typesym.name
- else
- if (p1.nodetype=loadn) then
- idstr:=tloadnode(p1).symtableentry.name
- else
- idstr:='';
- { if this is the case then the postfix handling is done in
- sub_expr if necessary }
- dopostfix:=not could_be_generic(idstr);
- end;
- if dopostfix then
- updatefpos:=postfixoperators(p1,again,getaddr);
- 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) or
- ((target_info.system in systems_jvm) and
- (current_structdef.typ=recorddef)))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);
- if (current_structdef.typ=objectdef) then
- begin
- 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;
- end
- else if target_info.system in systems_jvm then
- hclassdef:=java_fpcbaserecordtype
- else
- internalerror(2012012401);
- { 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,[ssf_has_inherited])
- else
- searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
- 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,[ssf_has_inherited])
- else
- searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
- 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 def_is_related(current_structdef,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:=cclassrefdef.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;
- callflags:=[cnf_inherited];
- include(current_procinfo.flags,pi_has_inherited);
- if anon_inherited then
- include(callflags,cnf_anon_inherited);
- do_member_read(hclassdef,getaddr,srsym,p1,again,callflags);
- 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,[ssf_search_helper]);
- 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,getaddr);
- 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;
- if token=_POINT then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- end;
- _REALNUMBER :
- begin
- p1:=real_const_node_from_pattern(pattern);
- consume(_REALNUMBER);
- if token=_POINT then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- 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,getaddr);
- 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,getaddr);
- end
- else
- begin
- p1:=ctypenode.create(hdef);
- end;
- end;
- _CSTRING :
- begin
- p1:=cstringconstnode.createpchar(ansistring2pchar(cstringpattern),length(cstringpattern),nil);
- consume(_CSTRING);
- if token in postfixoperator_tokens then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- end;
- _CCHAR :
- begin
- p1:=cordconstnode.create(ord(pattern[1]),cansichartype,true);
- consume(_CCHAR);
- if token=_POINT then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- end;
- _CWSTRING:
- begin
- p1:=cstringconstnode.createunistr(patternw);
- consume(_CWSTRING);
- if token in postfixoperator_tokens then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- end;
- _CWCHAR:
- begin
- p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true);
- consume(_CWCHAR);
- if token=_POINT then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- 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 postfixoperator_tokens then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end
- else
- consume(_RKLAMMER);
- end
- else
- p1:=factor(true,false);
- if token in postfixoperator_tokens then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- 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 postfixoperator_tokens then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- 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,nil);
- { -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,nil)
- else
- p1:=sub_expr(oppower,false,false,nil);
- p1:=cunaryminusnode.create(p1);
- end;
- end;
- _OP_NOT :
- begin
- consume(_OP_NOT);
- p1:=factor(false,false);
- p1:=cnotnode.create(p1);
- end;
- _NIL :
- begin
- consume(_NIL);
- p1:=cnilnode.create;
- { It's really ugly code nil^, but delphi allows it }
- if token in [_CARET,_POINT] then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- 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 nothing stops us }
- if (not assigned(p1.resultdef)) and dopostfix 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}
- procedure post_comp_expr_gendef(var def: tdef);
- var
- p1 : tnode;
- again : boolean;
- begin
- if not assigned(def) then
- internalerror(2011053001);
- again:=false;
- { handle potential typecasts, etc }
- p1:=handle_factor_typenode(def,false,again,nil,false);
- { parse postfix operators }
- postfixoperators(p1,again,false);
- if assigned(p1) and (p1.nodetype=typen) then
- def:=ttypenode(p1).typedef
- else
- def:=generrordef;
- end;
- {****************************************************************************
- Sub_Expr
- ****************************************************************************}
- function sub_expr(pred_level:Toperator_precedence;accept_equal,typeonly:boolean;factornode:tnode):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.}
- function istypenode(n:tnode):boolean;inline;
- { Checks whether the given node is a type node or a VMT node containing a
- typenode. This is used in the code for inline specializations in the
- _LT branch below }
- begin
- result:=assigned(n) and
- (
- (n.nodetype=typen) or
- (
- (n.nodetype=loadvmtaddrn) and
- (tloadvmtaddrnode(n).left.nodetype=typen)
- )
- );
- end;
- function gettypedef(n:tnode):tdef;inline;
- { This returns the typedef that belongs to the given typenode or
- loadvmtaddrnode. n must not be Nil! }
- begin
- if n.nodetype=typen then
- result:=ttypenode(n).typedef
- else
- result:=ttypenode(tloadvmtaddrnode(n).left).typedef;
- end;
- function getgenericsym(n:tnode;out srsym:tsym):boolean;
- var
- srsymtable : tsymtable;
- begin
- srsym:=nil;
- case n.nodetype of
- typen:
- srsym:=ttypenode(n).typedef.typesym;
- loadvmtaddrn:
- srsym:=ttypenode(tloadvmtaddrnode(n).left).typedef.typesym;
- loadn:
- if not searchsym_with_symoption(tloadnode(n).symtableentry.Name,srsym,srsymtable,sp_generic_dummy) then
- srsym:=nil;
- { TODO : handle const nodes }
- end;
- result:=assigned(srsym);
- end;
- label
- SubExprStart;
- var
- p1,p2 : tnode;
- oldt : Ttoken;
- filepos : tfileposinfo;
- again : boolean;
- gendef,parseddef : tdef;
- gensym : tsym;
- begin
- SubExprStart:
- if pred_level=highest_precedence then
- begin
- if factornode=nil then
- p1:=factor(false,typeonly)
- else
- p1:=factornode;
- end
- else
- p1:=sub_expr(succ(pred_level),true,typeonly,factornode);
- 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,nil);
- 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 :
- begin
- { we need to decice whether we have an inline specialization
- (type nodes to the left and right of "<", mode Delphi and
- ">" or "," following) or a normal "<" comparison }
- { TODO : p1 could be a non type if e.g. a variable with the
- same name is defined in the same unit where the
- generic is defined (though "same unit" is not
- necessarily needed) }
- if getgenericsym(p1,gensym) and
- { Attention: when nested specializations are supported
- p2 could be a loadn if a "<" follows }
- istypenode(p2) and
- (m_delphi in current_settings.modeswitches) and
- { TODO : add _LT, _LSHARPBRACKET for nested specializations }
- (token in [_GT,_RSHARPBRACKET,_COMMA]) then
- begin
- { this is an inline specialization }
- { retrieve the defs of two nodes }
- gendef:=nil;
- parseddef:=gettypedef(p2);
- if parseddef.typesym.typ<>typesym then
- Internalerror(2011051001);
- { check the hints for parseddef }
- check_hints(parseddef.typesym,parseddef.typesym.symoptions,parseddef.typesym.deprecatedmsg);
- { generate the specialization }
- generate_specialization(gendef,false,'',parseddef,gensym.RealName,p2.fileinfo);
- { we don't need the old left and right nodes anymore }
- p1.Free;
- p2.Free;
- { in case of a class or a record the specialized generic
- is always a classrefdef }
- again:=false;
- { handle potential typecasts, etc }
- p1:=handle_factor_typenode(gendef,false,again,nil,false);
- { parse postfix operators }
- if postfixoperators(p1,again,false) then
- if assigned(p1) then
- p1.fileinfo:=filepos
- else
- p1:=cerrornode.create;
- { with p1 now set we are in reality directly behind the
- call to "factor" thus we need to call down to that
- again }
- { This is disabled until specializations on the right
- hand side work as well, because
- "not working expressions" is better than "half working
- expressions" }
- {factornode:=p1;
- goto SubExprStart;}
- end
- else
- begin
- { this is a normal "<" comparison }
- { potential generic types that are followed by a "<": }
- { a) might not have their resultdef set }
- if not assigned(p1.resultdef) then
- do_typecheckpass(p1);
- { b) are not checked whether they are an undefined def,
- but not a generic parameter }
- if (p1.nodetype=typen) and
- (ttypenode(p1).typedef.typ=undefineddef) and
- assigned(ttypenode(p1).typedef.typesym) and
- not (sp_generic_para in ttypenode(p1).typedef.typesym.symoptions) then
- begin
- identifier_not_found(ttypenode(p1).typedef.typesym.RealName);
- p1.Free;
- p1:=cerrornode.create;
- end;
- { c) don't have their hints checked }
- if istypenode(p1) then
- begin
- gendef:=gettypedef(p1);
- if gendef.typ in [objectdef,recorddef,arraydef,procvardef] then
- check_hints(gendef.typesym,gendef.typesym.symoptions,gendef.typesym.deprecatedmsg);
- end;
- { Note: the second part of the expression will be needed
- for nested specializations }
- if istypenode(p2) {and
- not (token in [_LT, _LSHARPBRACKET])} then
- begin
- gendef:=gettypedef(p2);
- if gendef.typ in [objectdef,recorddef,arraydef,procvardef] then
- check_hints(gendef.typesym,gendef.typesym.symoptions,gendef.typesym.deprecatedmsg);
- end;
- { create the comparison node for "<" }
- p1:=caddnode.create(ltn,p1,p2)
- end;
- end;
- _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,
- _OP_IS :
- begin
- if token in [_LT, _LSHARPBRACKET] then
- begin
- { for now we're handling this as a generic declaration;
- there could be cases though (because of operator
- overloading) where this is the wrong decision... }
- { TODO : here the same note as in _LT applies as p2 could
- point to a variable, etc }
- gendef:=gettypedef(p2);
- if gendef.typesym.typ<>typesym then
- Internalerror(2011071401);
- { generate the specialization }
- generate_specialization(gendef,false,'');
- { we don't need the old p2 anymore }
- p2.Free;
- again:=false;
- { handle potential typecasts, etc }
- p2:=handle_factor_typenode(gendef,false,again,nil,false);
- { parse postfix operators }
- if postfixoperators(p2,again,false) then
- if assigned(p2) then
- p2.fileinfo:=filepos
- else
- p2:=cerrornode.create;
- { here we don't need to call back down to "factor", thus
- no "goto" }
- end;
- { now generate the "is" or "as" node }
- case oldt of
- _OP_AS:
- p1:=casnode.create(p1,p2);
- _OP_IS:
- p1:=cisnode.create(p1,p2);
- end;
- end;
- _OP_IN :
- p1:=cinnode.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 :
- begin
- p1:=cmoddivnode.create(modn,p1,p2);
- if m_iso in current_settings.modeswitches then
- include(p1.flags,nf_isomod);
- end;
- _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,nil);
- { 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,nil);
- { 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,nil);
- p1:=crangenode.create(p1,p2);
- end;
- _ASSIGNMENT :
- begin
- consume(_ASSIGNMENT);
- if assigned(p1.resultdef) and (p1.resultdef.typ=procvardef) then
- getprocvardef:=tprocvardef(p1.resultdef);
- p2:=sub_expr(opcompare,true,false,nil);
- 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,nil);
- p1:=gen_c_style_operator(addn,p1,p2);
- end;
- _MINUSASN :
- begin
- consume(_MINUSASN);
- p2:=sub_expr(opcompare,true,false,nil);
- p1:=gen_c_style_operator(subn,p1,p2);
- end;
- _STARASN :
- begin
- consume(_STARASN );
- p2:=sub_expr(opcompare,true,false,nil);
- p1:=gen_c_style_operator(muln,p1,p2);
- end;
- _SLASHASN :
- begin
- consume(_SLASHASN );
- p2:=sub_expr(opcompare,true,false,nil);
- 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.
|