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