1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853 |
- {
- 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;
- 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.
|