12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778 |
- {
- 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,compinnr,
- tokens,globtype,globals,constexp,
- pgentype;
- type
- texprflag = (
- ef_accept_equal,
- ef_type_only,
- ef_had_specialize,
- ef_check_attr_suffix
- );
- texprflags = set of texprflag;
- { reads a whole expression }
- function expr(dotypecheck:boolean) : tnode;
- { reads an expression without assignements and .. }
- function comp_expr(flags:texprflags):tnode;
- { reads a single factor }
- function factor(getaddr:boolean;flags:texprflags) : 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;spezcontext:tspecializationcontext);
- 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,cclasses,
- { global }
- verbose,
- systems,widestr,
- { symtable }
- symconst,symtable,symsym,symcpu,defutil,defcmp,
- { module }
- fmodule,ppu,
- { pass 1 }
- pass_1,
- 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;flags:texprflags;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([ef_accept_equal]);
- if not is_constintnode(p) then
- begin
- Message(parser_e_illegal_expression);
- { error recovery }
- consume(_RECKKLAMMER);
- end
- else
- begin
- { the node is a generic param while parsing a generic def
- so disable the range checking for the string }
- if parse_generic and
- (nf_generic_para in p.flags) then
- tordconstnode(p).value:=255;
- 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),true);
- end
- else
- if tordconstnode(p).value<>255 then
- def:=cstringdef.createshort(int64(tordconstnode(p).value),true);
- 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:=cansistringtype
- 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 : boolean;
- begin
- if token=end_of_paras then
- begin
- parse_paras:=nil;
- exit;
- end;
- { save old values }
- prev_in_args:=in_args;
- old_named_args_allowed:=named_args_allowed;
- { set para parsing values }
- in_args:=true;
- named_args_allowed:=false;
- 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([ef_accept_equal]);
- named_args_allowed:=false;
- if found_arg_name then
- begin
- argname:=p1;
- p1:=comp_expr([ef_accept_equal]);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]);
- p2:=ccallparanode.create(p1,p2);
- include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
- if try_to_consume(_COLON) then
- begin
- p1:=comp_expr([ef_accept_equal]);
- p2:=ccallparanode.create(p1,p2);
- include(tcallparanode(p2).callparaflags,cpf_is_colon_para);
- end
- end;
- until not try_to_consume(_COMMA);
- 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
- 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;
- if might_have_sideeffects(p1,[]) then
- begin
- typecheckpass(p1);
- result:=internalstatements(newstatement);
- hdef:=cpointerdef.getreusable(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 : tinlinenumber) : 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,
- in_chr_byte:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- consume(_RKLAMMER);
- p1:=geninlinenode(l,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([ef_accept_equal]);
- 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);
- if is_nested_pd(current_procinfo.procdef) then
- current_procinfo.set_needs_parentfp(exit_procinfo.procdef.parast.symtablelevel);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]);
- 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 }
- is_typeparam(p1.resultdef) then
- begin
- statement_syssym:=geninlinenode(in_sizeof_x,false,p1);
- { no packed bit support for these things }
- if l=in_bitsizeof_x then
- statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sizesinttype,true));
- { type sym is a generic parameter }
- if assigned(p1.resultdef.typesym) and (sp_generic_para in p1.resultdef.typesym.symoptions) then
- include(statement_syssym.flags,nf_generic_para);
- 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:=genintconstnode(p1.resultdef.size,sizesinttype);
- if (l = in_bitsizeof_x) then
- statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sizesinttype,true));
- end
- else
- statement_syssym:=genintconstnode(p1.resultdef.packedbitsize,sizesinttype);
- { type def is a struct with generic fields }
- if df_has_generic_fields in p1.resultdef.defoptions then
- include(statement_syssym.flags,nf_generic_para);
- { p1 not needed !}
- p1.destroy;
- end;
- end;
- in_typeinfo_x,
- in_objc_encode_x,
- in_gettypekind_x,
- in_ismanagedtype_x:
- begin
- if (l in [in_typeinfo_x,in_gettypekind_x,in_ismanagedtype_x]) or
- (m_objectivec1 in current_settings.modeswitches) then
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- { 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 [in_typeinfo_x,in_gettypekind_x,in_ismanagedtype_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_isconstvalue_x:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- consume(_RKLAMMER);
- p2:=geninlinenode(l,false,p1);
- statement_syssym:=p2;
- end;
- in_aligned_x,
- in_unaligned_x,
- in_volatile_x:
- begin
- err:=false;
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- 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([ef_accept_equal]);
- { 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);
- got_addrn:=true;
- p1:=factor(true,[]);
- { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
- if token<>_RKLAMMER then
- p1:=sub_expr(opcompare,[ef_accept_equal],p1);
- p1:=caddrnode.create(p1);
- got_addrn:=false;
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- {$ifdef i8086}
- in_faraddr_x :
- begin
- consume(_LKLAMMER);
- got_addrn:=true;
- p1:=factor(true,[]);
- { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
- if token<>_RKLAMMER then
- p1:=sub_expr(opcompare,[ef_accept_equal],p1);
- p1:=geninlinenode(in_faraddr_x,false,p1);
- got_addrn:=false;
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- {$endif i8086}
- in_ofs_x :
- begin
- if target_info.system in systems_managed_vm then
- message(parser_e_feature_unsupported_for_vm);
- consume(_LKLAMMER);
- got_addrn:=true;
- p1:=factor(true,[]);
- { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
- if token<>_RKLAMMER then
- p1:=sub_expr(opcompare,[ef_accept_equal],p1);
- p1:=caddrnode.create(p1);
- include(taddrnode(p1).addrnodeflags,anf_ofs);
- got_addrn:=false;
- { Ofs() returns a cardinal/qword, not a pointer }
- inserttypeconv_internal(p1,uinttype);
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- in_seg_x :
- begin
- consume(_LKLAMMER);
- got_addrn:=true;
- p1:=factor(true,[]);
- { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
- if token<>_RKLAMMER then
- p1:=sub_expr(opcompare,[ef_accept_equal],p1);
- p1:=geninlinenode(in_seg_x,false,p1);
- got_addrn:=false;
- consume(_RKLAMMER);
- statement_syssym:=p1;
- end;
- in_high_x,
- in_low_x :
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]);
- if try_to_consume(_COMMA) then
- p2:=ccallparanode.create(comp_expr([ef_accept_equal]),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([ef_accept_equal]).free;
- if try_to_consume(_COMMA) then
- comp_expr([ef_accept_equal]).free;
- statement_syssym:=cerrornode.create;
- consume(_RKLAMMER);
- end
- else
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- Consume(_COMMA);
- if not(codegenerror) then
- p2:=ccallparanode.create(comp_expr([ef_accept_equal]),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
- statement_syssym:=inline_concat;
- 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,[]);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]), nil);
- consume(_COMMA);
- p2 := ccallparanode.create(comp_expr([ef_accept_equal]),p1);
- if try_to_consume(_COMMA) then
- p2 := ccallparanode.create(comp_expr([ef_accept_equal]),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([ef_accept_equal]);
- consume(_COMMA);
- p2:=comp_expr([ef_accept_equal]);
- 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([ef_accept_equal]);
- consume(_COMMA);
- p2:=comp_expr([ef_accept_equal]);
- consume(_COMMA);
- paras:=comp_expr([ef_accept_equal]);
- 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([ef_accept_equal]);
- if try_to_consume(_COMMA) then
- p2:=comp_expr([ef_accept_equal])
- 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([ef_accept_equal]);
- p1.destroy;
- consume(_RKLAMMER);
- end;
- statement_syssym:=geninlinenode(l,false,nil);
- end;
- *)
- in_default_x:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- def:=nil;
- single_type(def,[stoAllowSpecialization]);
- statement_syssym:=cerrornode.create;
- if def<>generrordef then
- { "type expected" error is already done by single_type }
- if def.typ=forwarddef then
- Message1(type_e_type_is_not_completly_defined,tforwarddef(def).tosymname^)
- else
- begin
- statement_syssym.free;
- statement_syssym:=geninlinenode(in_default_x,false,ctypenode.create(def));
- end;
- { consume the right bracket here for a nicer error position }
- consume(_RKLAMMER);
- end;
- in_setstring_x_y_z:
- begin
- statement_syssym := inline_setstring;
- end;
- in_delete_x_y_z:
- begin
- statement_syssym:=inline_delete;
- end;
- in_insert_x_y_z:
- begin
- statement_syssym:=inline_insert;
- end;
- in_const_eh_return_data_regno:
- begin
- consume(_LKLAMMER);
- in_args:=true;
- p1:=comp_expr([ef_accept_equal]);
- p2:=geninlinenode(l,true,p1);
- consume(_RKLAMMER);
- statement_syssym:=p2;
- 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;
- else
- ;
- 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;spezcontext:tspecializationcontext);
- 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? Check token because
- in the case of opening parenthesis is possible to get pointer to
- function result (lack of checking for token was the reason of
- tw10933.pp test failure) }
- if getaddr and (token<>_LKLAMMER) then
- begin
- { for now we don't support pointers to generic functions, but since
- this is only temporary we use a non translated message }
- if assigned(spezcontext) then
- begin
- comment(v_error, 'Pointers to generics functions not implemented');
- p1:=cerrornode.create;
- spezcontext.free;
- exit;
- end;
- { 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
- begin
- typecheckpass(p1);
- if (p1.resultdef.typ=objectdef) then
- { so we can create the correct method pointer again in case
- this is a "objectprocvar:[email protected]" expression }
- tloadnode(p2).symtable:=tobjectdef(p1.resultdef).symtable
- else
- p1.free;
- end;
- 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,spezcontext);
- end
- else
- p1:=ccallnode.create(para,tprocsym(sym),st,p1,callflags,spezcontext);
- 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.free;
- { 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,nil);
- addsymref(sym);
- paras:=nil;
- consume(_ASSIGNMENT);
- { read the expression }
- if propsym.propdef.typ=procvardef then
- getprocvardef:=tprocvardef(propsym.propdef);
- p2:=comp_expr([ef_accept_equal]);
- 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,p1) then
- propaccesslist_to_node(p1,st,propaccesslist);
- include(p1.flags,nf_isproperty);
- consume(_ASSIGNMENT);
- { read the expression }
- p2:=comp_expr([ef_accept_equal]);
- 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,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,nil);
- 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;spezcontext:tspecializationcontext);
- var
- isclassref:boolean;
- isrecordtype:boolean;
- isobjecttype:boolean;
- ishelpertype: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 }
- spezcontext.free;
- again:=false;
- end
- else
- begin
- if assigned(p1) then
- begin
- if not assigned(p1.resultdef) then
- do_typecheckpass(p1);
- isclassref:=(p1.resultdef.typ=classrefdef);
- isrecordtype:=(p1.nodetype=typen) and (p1.resultdef.typ=recorddef);
- isobjecttype:=(p1.nodetype=typen) and is_object(p1.resultdef);
- ishelpertype:=is_objectpascal_helper(tdef(sym.owner.defowner)) and
- (p1.nodetype=typen) and
- not is_objectpascal_helper(p1.resultdef)
- {and
- not (cnf_inherited in callflags)};
- end
- else
- begin
- isclassref:=false;
- isrecordtype:=false;
- isobjecttype:=false;
- ishelpertype:=false;
- end;
- if assigned(spezcontext) and not (sym.typ=procsym) then
- internalerror(2015091801);
- { 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,spezcontext);
- { we need to know which procedure is called }
- do_typecheckpass(p1);
- { calling using classref? }
- if (
- isclassref or
- (
- (isobjecttype or
- isrecordtype or
- ishelpertype) and
- not (cnf_inherited in callflags)
- )
- ) and
- (p1.nodetype=calln) and
- assigned(tcallnode(p1).procdefinition) then
- begin
- if not isobjecttype 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);
- end
- else
- begin
- { with objects, you can also do this:
- type
- tparent = object
- procedure test;
- end;
- tchild = object(tchild)
- procedure test;
- end;
- procedure tparent.test;
- begin
- end;
- procedure tchild.test;
- begin
- tparent.test;
- end;
- }
- if (tcallnode(p1).procdefinition.proctypeoption<>potype_constructor) and
- not(po_staticmethod in tcallnode(p1).procdefinition.procoptions) and
- (not assigned(current_structdef) or
- not def_is_related(current_structdef,structh)) then
- begin
- p1.free;
- p1:=cerrornode.create;
- Message(parser_e_only_static_members_via_object_type);
- exit;
- end;
- end;
- { 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
- Note: structh might be Nil in case of a type helper }
- if assigned(structh) and
- (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,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([ef_accept_equal]);
- 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_specialize_inline_specialization(var srsym:tsym;out srsymtable:tsymtable;out spezcontext:tspecializationcontext):boolean;
- var
- spezdef : tdef;
- symname : tsymstr;
- begin
- result:=false;
- spezcontext:=nil;
- srsymtable:=nil;
- if not assigned(srsym) then
- message1(sym_e_id_no_member,orgpattern)
- else
- if not (srsym.typ in [typesym,procsym]) then
- message(type_e_type_id_expected)
- else
- begin
- if srsym.typ=typesym then
- spezdef:=ttypesym(srsym).typedef
- else if tprocsym(srsym).procdeflist.count>0 then
- spezdef:=tdef(tprocsym(srsym).procdeflist[0])
- else
- spezdef:=nil;
- if (not assigned(spezdef) or (spezdef.typ=errordef)) and (sp_generic_dummy in srsym.symoptions) then
- symname:=srsym.RealName
- else
- symname:='';
- spezdef:=generate_specialization_phase1(spezcontext,spezdef,symname,srsym.owner);
- case spezdef.typ of
- errordef:
- begin
- spezcontext.free;
- spezcontext:=nil;
- srsym:=generrorsym;
- end;
- procdef:
- begin
- if block_type<>bt_body then
- begin
- message(parser_e_illegal_expression);
- spezcontext.free;
- spezcontext:=nil;
- srsym:=generrorsym;
- end
- else
- begin
- srsym:=tprocdef(spezdef).procsym;
- srsymtable:=srsym.owner;
- result:=true;
- end;
- end;
- objectdef,
- recorddef,
- arraydef,
- procvardef:
- begin
- spezdef:=generate_specialization_phase2(spezcontext,tstoreddef(spezdef),false,'');
- spezcontext.free;
- spezcontext:=nil;
- if spezdef<>generrordef then
- begin
- srsym:=spezdef.typesym;
- srsymtable:=srsym.owner;
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- result:=true;
- end;
- end;
- else
- internalerror(2015070302);
- end;
- end;
- end;
- function handle_factor_typenode(hdef:tdef;getaddr:boolean;var again:boolean;sym:tsym;typeonly:boolean):tnode;
- var
- srsym : tsym;
- srsymtable : tsymtable;
- erroroutresult,
- isspecialize : boolean;
- spezcontext : tspecializationcontext;
- savedfilepos : tfileposinfo;
- begin
- spezcontext:=nil;
- 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([ef_accept_equal]);
- 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;
- if not (m_delphi in current_settings.modeswitches) and
- (block_type in inline_specialization_block_types) and
- (token=_ID) and
- (idtoken=_SPECIALIZE) then
- begin
- consume(_ID);
- if token<>_ID then
- message(type_e_type_id_expected);
- isspecialize:=true;
- end
- else
- isspecialize:=false;
- { search also in inherited methods }
- searchsym_in_class(tobjectdef(hdef),tobjectdef(current_structdef),pattern,srsym,srsymtable,[ssf_search_helper]);
- if isspecialize then
- begin
- consume(_ID);
- if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- begin
- result.free;
- result:=cerrornode.create;
- end;
- end
- else
- begin
- if assigned(srsym) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- consume(_ID);
- end;
- if result.nodetype<>errorn then
- do_member_read(tabstractrecorddef(hdef),false,srsym,result,again,[],spezcontext)
- else
- spezcontext.free;
- end
- else
- begin
- { handles:
- * @TObject.Load
- * static methods and variables }
- result:=ctypenode.create(hdef);
- ttypenode(result).typesym:=sym;
- if not (m_delphi in current_settings.modeswitches) and
- (block_type in inline_specialization_block_types) and
- (token=_ID) and
- (idtoken=_SPECIALIZE) then
- begin
- consume(_ID);
- if token<>_ID then
- message(type_e_type_id_expected);
- isspecialize:=true;
- end
- else
- isspecialize:=false;
- erroroutresult:=true;
- { TP allows also @TMenu.Load if Load is only }
- { defined in an anchestor class }
- srsym:=search_struct_member(tabstractrecorddef(hdef),pattern);
- if isspecialize and assigned(srsym) then
- begin
- consume(_ID);
- if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- erroroutresult:=false;
- end
- else
- begin
- if assigned(srsym) then
- begin
- savedfilepos:=current_filepos;
- consume(_ID);
- if not (sp_generic_dummy in srsym.symoptions) or
- not (token in [_LT,_LSHARPBRACKET]) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,savedfilepos)
- else
- result:=cspecializenode.create(result,getaddr,srsym);
- erroroutresult:=false;
- end
- else
- Message1(sym_e_id_no_member,orgpattern);
- end;
- if erroroutresult then
- begin
- result.free;
- result:=cerrornode.create;
- end
- else
- if result.nodetype<>specializen then
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,result,again,[],spezcontext);
- 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,[],nil);
- 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;
- if current_settings.fputype=fpu_none then
- begin
- Message(parser_e_unsupported_real);
- result:=cerrornode.create;
- exit;
- end;
- 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
- result:=crealconstnode.create(d,pbestrealtype^);
- val(pattern,cur,code);
- if code=0 then
- trealconstnode(result).value_currency:=cur;
- 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([ef_accept_equal]);
- until not try_to_consume(_COMMA);
- consume(_RECKKLAMMER);
- end
- else if try_to_consume(_LKLAMMER) then
- begin
- repeat
- comp_expr([ef_accept_equal]);
- 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 : longint;
- elements: tfplist;
- arraydef: tdef;
- begin
- { create statements with call initialize the arguments and
- call fpc_dynarr_setlength }
- newblock:=internalstatements(newstatement);
- { store all indices in a temporary array }
- countindices:=0;
- elements:=tfplist.Create;
- repeat
- p4:=comp_expr([ef_accept_equal]);
- elements.add(p4);
- until not try_to_consume(_COMMA);
- arraydef:=carraydef.getreusable(s32inttype,elements.count);
- temp:=ctempcreatenode.create(arraydef,arraydef.size,tt_persistent,false);
- addstatement(newstatement,temp);
- for countindices:=0 to elements.count-1 do
- begin
- addstatement(newstatement,
- cassignmentnode.create(
- cvecnode.create(
- ctemprefnode.create(temp),
- genintconstnode(countindices)
- ),
- tnode(elements[countindices])
- )
- );
- end;
- countindices:=elements.count;
- elements.free;
- consume(_RECKKLAMMER);
- { we need only a write access if a := follows }
- if token=_ASSIGNMENT then
- begin
- consume(_ASSIGNMENT);
- p4:=comp_expr([ef_accept_equal]);
- { create call to fpc_vararray_put }
- paras:=ccallparanode.create(cordconstnode.create
- (countindices,s32inttype,true),
- ccallparanode.create(caddrnode.create_internal
- (cvecnode.create(ctemprefnode.create(temp),genintconstnode(0))),
- 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([ef_accept_equal])));
- 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(temp2),
- 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,bt_const]) 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+[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,[],nil);
- 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;
- autoderef,
- erroroutp1,
- allowspecialize,
- isspecialize,
- found,
- haderror,
- nodechanged : boolean;
- calltype: tdispcalltype;
- valstr,expstr : string;
- intval : qword;
- code : integer;
- strdef : tdef;
- spezcontext : tspecializationcontext;
- old_current_filepos : tfileposinfo;
- label
- skipreckklammercheck,
- skippointdefcheck;
- begin
- result:=false;
- again:=true;
- while again do
- begin
- spezcontext:=nil;
- { 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_isolike_io 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)),
- cpointerdef.getreusable(tfiledef(p1.resultdef).typedfiledef)));
- typecheckpass(p1);
- end;
- else
- internalerror(2019050530);
- end;
- end
- else if not(p1.resultdef.typ in [pointerdef,undefineddef]) 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([ef_accept_equal]);
- { Support Pbytevar[0..9] which returns array [0..9].}
- if try_to_consume(_POINTPOINT) then
- p2:=crangenode.create(p2,comp_expr([ef_accept_equal]));
- p1:=cvecnode.create(p1,p2);
- end;
- variantdef:
- begin
- handle_variantarray;
- { the RECKKLAMMER is already read }
- goto skipreckklammercheck;
- end;
- stringdef :
- begin
- p2:=comp_expr([ef_accept_equal]);
- { Support string[0..9] which returns array [0..9] of char.}
- if try_to_consume(_POINTPOINT) then
- p2:=crangenode.create(p2,comp_expr([ef_accept_equal]));
- p1:=cvecnode.create(p1,p2);
- end;
- arraydef:
- begin
- p2:=comp_expr([ef_accept_equal]);
- { support SEG:OFS for go32v2/msdos Mem[] }
- if (target_info.system in [system_i386_go32v2,system_i386_watcom,system_i8086_msdos,system_i8086_win16,system_i8086_embedded]) 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([ef_accept_equal]);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]),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([ef_accept_equal]));
- p1:=cvecnode.create(p1,p2);
- include(tvecnode(p1).flags,nf_memindex);
- end;
- {$else}
- internalerror(2013053105);
- {$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([ef_accept_equal]));
- 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([ef_accept_equal]);
- 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);
- allowspecialize:=not (m_delphi in current_settings.modeswitches) and (block_type in inline_specialization_block_types);
- if allowspecialize and (token=_ID) and (idtoken=_SPECIALIZE) then
- begin
- //consume(_ID);
- isspecialize:=true;
- end
- else
- isspecialize:=false;
- autoderef:=false;
- 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);
- autoderef:=true;
- 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
- begin
- haderror:=true;
- intval:=intval; // Hackfix the "var assigned but never used" note.
- end;
- 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);
- 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 isspecialize or (token=_ID) then
- begin
- erroroutp1:=true;
- srsym:=nil;
- structh:=tabstractrecorddef(p1.resultdef);
- if isspecialize then
- begin
- { consume the specialize }
- consume(_ID);
- if token<>_ID then
- consume(_ID)
- else
- begin
- searchsym_in_record(structh,pattern,srsym,srsymtable);
- consume(_ID);
- if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- erroroutp1:=false;
- end;
- end
- else
- begin
- searchsym_in_record(structh,pattern,srsym,srsymtable);
- if assigned(srsym) then
- begin
- old_current_filepos:=current_filepos;
- consume(_ID);
- if not (sp_generic_dummy in srsym.symoptions) or
- not (token in [_LT,_LSHARPBRACKET]) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos)
- else
- p1:=cspecializenode.create(p1,getaddr,srsym);
- erroroutp1:=false;
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- { try to clean up }
- consume(_ID);
- end;
- end;
- if erroroutp1 then
- begin
- p1.free;
- p1:=cerrornode.create;
- end
- else
- if p1.nodetype<>specializen then
- do_member_read(structh,getaddr,srsym,p1,again,[],spezcontext);
- 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 then
- begin
- if not try_type_helper(p1,nil) then
- begin
- if p1.nodetype=typen 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
- else
- begin
- Message(parser_e_invalid_qualifier);
- 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
- else
- if (token<>_ID) or not try_type_helper(p1,nil) then
- 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([ef_accept_equal]);
- { 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
- erroroutp1:=true;
- if token=_ID then
- begin
- srsym:=nil;
- structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
- if isspecialize then
- begin
- { consume the specialize }
- consume(_ID);
- if token<>_ID then
- consume(_ID)
- else
- begin
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
- consume(_ID);
- if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- erroroutp1:=false;
- end;
- end
- else
- begin
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
- if assigned(srsym) then
- begin
- old_current_filepos:=current_filepos;
- consume(_ID);
- if not (sp_generic_dummy in srsym.symoptions) or
- not (token in [_LT,_LSHARPBRACKET]) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos)
- else
- p1:=cspecializenode.create(p1,getaddr,srsym);
- erroroutp1:=false;
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- { try to clean up }
- consume(_ID);
- end;
- end;
- if erroroutp1 then
- begin
- p1.free;
- p1:=cerrornode.create;
- end
- else
- if p1.nodetype<>specializen then
- do_member_read(structh,getaddr,srsym,p1,again,[],spezcontext);
- end
- else { Error }
- Consume(_ID);
- end;
- objectdef:
- begin
- if isspecialize or (token=_ID) then
- begin
- erroroutp1:=true;
- srsym:=nil;
- structh:=tobjectdef(p1.resultdef);
- if isspecialize then
- begin
- { consume the "specialize" }
- consume(_ID);
- if token<>_ID then
- consume(_ID)
- else
- begin
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
- consume(_ID);
- if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- erroroutp1:=false;
- end;
- end
- else
- begin
- searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]);
- if assigned(srsym) then
- begin
- old_current_filepos:=current_filepos;
- consume(_ID);
- if not (sp_generic_dummy in srsym.symoptions) or
- not (token in [_LT,_LSHARPBRACKET]) then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos)
- else
- p1:=cspecializenode.create(p1,getaddr,srsym);
- erroroutp1:=false;
- end
- else
- begin
- Message1(sym_e_id_no_member,orgpattern);
- { try to clean up }
- consume(_ID);
- end;
- end;
- if erroroutp1 then
- begin
- p1.free;
- p1:=cerrornode.create;
- end
- else
- if p1.nodetype<>specializen then
- do_member_read(structh,getaddr,srsym,p1,again,[],spezcontext);
- 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],nil);
- { 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
- if autoderef then
- begin
- { always try with the not dereferenced node }
- p2:=tderefnode(p1).left;
- found:=try_type_helper(p2,nil);
- if found then
- begin
- tderefnode(p1).left:=nil;
- p1.destroy;
- p1:=p2;
- end;
- end
- else
- 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([ef_accept_equal]);
- 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:boolean;flags:texprflags) : tnode;
- {---------------------------------------------
- Factor_read_id
- ---------------------------------------------}
- procedure factor_read_id(out p1:tnode;out 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;
- consumeid,
- wasgenericdummy,
- allowspecialize,
- isspecialize,
- unit_found, tmpgetaddr: boolean;
- dummypos,
- tokenpos: tfileposinfo;
- spezcontext : tspecializationcontext;
- cufflags : tconsume_unitsym_flags;
- begin
- { allow post fix operators }
- again:=true;
- { preinitalize tokenpos }
- tokenpos:=current_filepos;
- p1:=nil;
- spezcontext:=nil;
- { avoid warning }
- fillchar(dummypos,sizeof(dummypos),0);
- allowspecialize:=not (m_delphi in current_settings.modeswitches) and
- not (ef_had_specialize in flags) and
- (block_type in inline_specialization_block_types);
- if allowspecialize and (token=_ID) and (idtoken=_SPECIALIZE) then
- begin
- consume(_ID);
- isspecialize:=true;
- end
- else
- isspecialize:=ef_had_specialize in flags;
- { first check for identifier }
- if token<>_ID then
- begin
- srsym:=generrorsym;
- srsymtable:=nil;
- consume(_ID);
- unit_found:=false;
- end
- else
- begin
- storedpattern:=pattern;
- orgstoredpattern:=orgpattern;
- { store the position of the token before consuming it }
- tokenpos:=current_filepos;
- consumeid:=true;
- srsym:=nil;
- if ef_check_attr_suffix in flags then
- begin
- if not (ef_type_only in flags) then
- internalerror(2019063001);
- consume(_ID);
- consumeid:=false;
- if token<>_POINT then
- searchsym_type(storedpattern+custom_attribute_suffix,srsym,srsymtable);
- end;
- if not assigned(srsym) then
- begin
- if ef_type_only in flags then
- searchsym_type(storedpattern,srsym,srsymtable)
- else
- searchsym(storedpattern,srsym,srsymtable);
- end;
- { handle unit specification like System.Writeln }
- if not isspecialize then
- begin
- cufflags:=[];
- if consumeid then
- include(cufflags,cuf_consume_id);
- if allowspecialize then
- include(cufflags,cuf_allow_specialize);
- if ef_check_attr_suffix in flags then
- include(cufflags,cuf_check_attr_suffix);
- unit_found:=try_consume_unitsym(srsym,srsymtable,t,cufflags,isspecialize,pattern);
- if unit_found then
- consumeid:=true;
- end
- else
- begin
- unit_found:=false;
- t:=_ID;
- end;
- if consumeid then
- begin
- storedpattern:=pattern;
- orgstoredpattern:=orgpattern;
- { store the position of the token before consuming it }
- tokenpos:=current_filepos;
- consume(t);
- end;
- { named parameter support }
- found_arg_name:=false;
- if not(unit_found) and
- not isspecialize and
- named_args_allowed and
- (token=_ASSIGNMENT) then
- begin
- found_arg_name:=true;
- p1:=cstringconstnode.createstr(orgstoredpattern);
- consume(_ASSIGNMENT);
- exit;
- end;
- if isspecialize then
- begin
- if not assigned(srsym) then
- begin
- identifier_not_found(orgstoredpattern,tokenpos);
- srsym:=generrorsym;
- srsymtable:=nil;
- end
- else
- begin
- {$push}
- {$warn 5036 off}
- hdef:=generate_specialization_phase1(spezcontext,nil,nil,orgstoredpattern,nil,dummypos);
- {$pop}
- if hdef=generrordef then
- begin
- spezcontext.free;
- spezcontext:=nil;
- srsym:=generrorsym;
- srsymtable:=nil;
- end
- else
- begin
- if hdef.typ in [objectdef,recorddef,procvardef,arraydef] then
- begin
- hdef:=generate_specialization_phase2(spezcontext,tstoreddef(hdef),false,'');
- spezcontext.free;
- spezcontext:=nil;
- if hdef<>generrordef then
- begin
- srsym:=hdef.typesym;
- srsymtable:=srsym.owner;
- end
- else
- begin
- srsym:=generrorsym;
- srsymtable:=nil;
- end;
- end
- else
- if hdef.typ=procdef then
- begin
- if block_type<>bt_body then
- begin
- message(parser_e_illegal_expression);
- srsym:=generrorsym;
- srsymtable:=nil;
- end
- else
- begin
- srsym:=tprocdef(hdef).procsym;
- if assigned(spezcontext.symtable) then
- srsymtable:=spezcontext.symtable
- else
- srsymtable:=srsym.owner;
- end;
- end
- else
- internalerror(2015061204);
- end;
- end;
- end;
- wasgenericdummy:=false;
- if assigned(srsym) and
- (sp_generic_dummy in srsym.symoptions) and
- (srsym.typ in [procsym,typesym]) and
- (
- (
- (m_delphi in current_settings.modeswitches) and
- not (token in [_LT, _LSHARPBRACKET]) and
- (
- (
- (srsym.typ=typesym) and
- (ttypesym(srsym).typedef.typ=undefineddef)
- ) or (
- (srsym.typ=procsym) and
- (tprocsym(srsym).procdeflist.count=0)
- )
- )
- )
- or
- (
- not (m_delphi in current_settings.modeswitches) and
- not isspecialize and
- (
- not parse_generic or
- not (
- assigned(current_structdef) and
- assigned(get_generic_in_hierarchy_by_name(srsym,current_structdef))
- )
- )
- )
- ) then
- begin
- srsym:=resolve_generic_dummysym(srsym.name);
- if assigned(srsym) then
- srsymtable:=srsym.owner
- else
- begin
- srsymtable:=nil;
- wasgenericdummy:=true;
- end;
- 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]) or
- (
- (ttypesym(srsym).typedef.typ=errordef) and
- (sp_generic_dummy in srsym.symoptions)
- )
- ) 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:=tstoredsym.create(undefinedsym,'$undefinedsym');
- srsymtable:=nil;
- end
- else
- begin
- if wasgenericdummy then
- messagepos(tokenpos,parser_e_no_generics_as_types)
- else
- 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,m_extpas] * 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,[],nil)
- 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
- if (m_delphi in current_settings.modeswitches) and
- (sp_generic_dummy in srsym.symoptions) and
- (token in [_LT,_LSHARPBRACKET]) then
- begin
- if block_type in [bt_type,bt_const_type,bt_var_type] then
- begin
- if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) or (srsym.typ=procsym) then
- begin
- spezcontext.free;
- p1:=cerrornode.create;
- if try_to_consume(_LKLAMMER) then
- begin
- parse_paras(false,false,_RKLAMMER);
- consume(_RKLAMMER);
- end;
- end
- else
- begin
- if srsym.typ<>typesym then
- internalerror(2015071705);
- hdef:=ttypesym(srsym).typedef;
- p1:=handle_factor_typenode(hdef,getaddr,again,srsym,ef_type_only in flags);
- end;
- end
- else
- p1:=cspecializenode.create(nil,getaddr,srsym)
- 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
- include(current_module.moduleflags,mf_uses_variants);
- p1:=handle_factor_typenode(hdef,getaddr,again,srsym,ef_type_only in flags);
- end;
- end;
- end;
- enumsym :
- begin
- p1:=genenumnode(tenumsym(srsym));
- end;
- constsym :
- begin
- if tconstsym(srsym).consttyp=constresourcestring then
- begin
- p1:=cloadnode.create(srsym,srsymtable);
- do_typecheckpass(p1);
- p1.resultdef:=getansistringdef;
- end
- else
- p1:=genconstsymtree(tconstsym(srsym));
- end;
- procsym :
- begin
- p1:=nil;
- if (m_delphi in current_settings.modeswitches) and
- (sp_generic_dummy in srsym.symoptions) and
- (token in [_LT,_LSHARPBRACKET]) then
- begin
- p1:=cspecializenode.create(nil,getaddr,srsym)
- end
- { check if it's a method/class method }
- else 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
- begin
- do_member_read(tabstractrecorddef(hdef),getaddr,srsym,p1,again,[],spezcontext);
- spezcontext:=nil;
- end
- 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];
- { TP7 uglyness: @proc^ is parsed as (@proc)^,
- but @notproc^ is parsed as @(notproc^) }
- if m_tp_procvar in current_settings.modeswitches then
- tmpgetaddr:=getaddr and not(token in [_POINT,_LECKKLAMMER])
- else
- tmpgetaddr:=getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER]);
- do_proc_call(srsym,srsymtable,nil,tmpgetaddr,
- again,p1,callflags,spezcontext);
- spezcontext:=nil;
- 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
- begin
- p1:=ctypenode.create(hdef);
- if not is_record(hdef) then
- p1:=cloadvmtaddrnode.create(p1);
- end
- 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,[],nil)
- 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
- include(current_procinfo.flags,pi_has_interproclabel);
- if (current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
- Message(sym_e_interprocgoto_into_init_final_code_not_allowed);
- end;
- 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(true);
- { 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(spezcontext) then
- internalerror(2015061207);
- 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;
- 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
- p1:=comp_expr([ef_accept_equal]);
- if try_to_consume(_POINTPOINT) then
- begin
- p2:=comp_expr([ef_accept_equal]);
- 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;
- { there could be more elements }
- until not try_to_consume(_COMMA);
- buildp.allow_array_constructor:=block_type in [bt_body,bt_except];
- 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;
- spezcontext : tspecializationcontext;
- isspecialize,
- mightbegeneric,
- useself,
- 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;
- isspecialize:=false;
- 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 (p1.nodetype=specializen) then
- { post fix operators are handled after specialization }
- dopostfix:=false
- else
- if (m_delphi in current_settings.modeswitches) and
- (block_type=bt_body) and
- (token in [_LT,_LSHARPBRACKET]) then
- begin
- idstr:='';
- case p1.nodetype of
- typen:
- idstr:=ttypenode(p1).typesym.name;
- loadvmtaddrn:
- if tloadvmtaddrnode(p1).left.nodetype=typen then
- idstr:=ttypenode(tloadvmtaddrnode(p1).left).typesym.name;
- loadn:
- idstr:=tloadnode(p1).symtableentry.name;
- calln:
- idstr:=tcallnode(p1).symtableprocentry.name;
- else
- ;
- end;
- { if this is the case then the postfix handling is done in
- sub_expr if necessary }
- dopostfix:=not could_be_generic(idstr);
- end;
- { TP7 uglyness: @proc^ is parsed as (@proc)^, but @notproc^ is parsed
- as @(notproc^) }
- if (m_tp_procvar in current_settings.modeswitches) and (token=_CARET) and
- getaddr and (p1.nodetype=loadn) and (tloadnode(p1).symtableentry.typ=procsym) then
- dopostfix:=false;
- { maybe an additional parameter instead of misusing hadspezialize? }
- if dopostfix and not (ef_had_specialize in flags) then
- updatefpos:=postfixoperators(p1,again,getaddr);
- end
- else
- begin
- updatefpos:=true;
- case token of
- _RETURN :
- begin
- consume(_RETURN);
- p1:=nil;
- if not(token in [_SEMICOLON,_ELSE,_END]) then
- begin
- p1:=comp_expr([ef_accept_equal]);
- 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;
- p1 := cexitnode.create(p1);
- 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
- (tobjectdef(current_structdef).helpertype=ht_record) 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);
- spezcontext:=nil;
- { 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
- if not (m_delphi in current_settings.modeswitches) and
- (block_type in inline_specialization_block_types) and
- (token=_ID) and
- (idtoken=_SPECIALIZE) then
- begin
- consume(_ID);
- if token<>_ID then
- message(parser_e_methode_id_expected);
- isspecialize:=true;
- end
- else
- isspecialize:=false;
- 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]);
- if isspecialize and assigned(srsym) then
- begin
- if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
- srsym:=nil;
- end;
- end;
- if assigned(srsym) then
- begin
- mightbegeneric:=(m_delphi in current_settings.modeswitches) and
- (token in [_LT,_LSHARPBRACKET]) and
- (sp_generic_dummy in srsym.symoptions);
- { load the procdef from the inherited class and
- not from self }
- case srsym.typ of
- typesym,
- procsym:
- begin
- { typesym is only a valid choice if we're dealing
- with a potential generic }
- if (srsym.typ=typesym) and not mightbegeneric then
- begin
- Message(parser_e_methode_id_expected);
- p1:=cerrornode.create;
- end
- else
- begin
- useself:=false;
- 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
- begin
- hdef:=tobjectdef(srsym.Owner.defowner).extendeddef;
- useself:=true;
- end
- else
- begin
- hdef:=tdef(srsym.Owner.defowner);
- useself:=true;
- end;
- 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);
- if useself then
- begin
- p1:=ctypeconvnode.create_internal(load_self_node,hdef);
- end
- else
- begin
- p1:=ctypenode.create(hdef);
- { we need to allow helpers here }
- ttypenode(p1).helperallowed:=true;
- end;
- end;
- end;
- propertysym:
- ;
- else
- begin
- Message(parser_e_methode_id_expected);
- p1:=cerrornode.create;
- end;
- end;
- if mightbegeneric then
- begin
- p1:=cspecializenode.create_inherited(p1,getaddr,srsym,hclassdef);
- end
- else
- begin
- if not isspecialize then
- check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
- 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,spezcontext);
- end;
- if p1.nodetype=errorn then
- spezcontext.free;
- 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,[],nil);
- 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;
- if p1.nodetype<>specializen then
- 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([ef_accept_equal]);
- 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);
- if token=_POINT then
- begin
- again:=true;
- { handle type helpers here }
- postfixoperators(p1,again,getaddr);
- end;
- end;
- end;
- _FILE :
- begin
- hdef:=cfiletype;
- consume(_FILE);
- { FILE can be also a type cast }
- if try_to_consume(_LKLAMMER) then
- begin
- p1:=comp_expr([ef_accept_equal]);
- 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
- if getlengthwidestring(patternw)=1 then
- p1:=cordconstnode.create(ord(getcharwidestring(patternw,0)),cwidechartype,true)
- else
- 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,[]);
- { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
- if token<>_RKLAMMER then
- p1:=sub_expr(opcompare,[ef_accept_equal],p1);
- consume(_RKLAMMER);
- end
- else
- p1:=factor(true,[]);
- if (token in postfixoperator_tokens) and
- { TP7 uglyness: @proc^ is parsed as (@proc)^, but @notproc^
- is parsed as @(notproc^) }
- not
- (
- (m_tp_procvar in current_settings.modeswitches) and
- (token=_CARET) and (p1.nodetype=loadn) and (tloadnode(p1).symtableentry.typ=procsym)
- )
- 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(taddrnode(p1).addrnodeflags,anf_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;
- if (token in postfixoperator_tokens) then
- begin
- again:=true;
- postfixoperators(p1,again,getaddr);
- end;
- end;
- _LKLAMMER :
- begin
- consume(_LKLAMMER);
- p1:=comp_expr([ef_accept_equal]);
- 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,[]);
- 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,[],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,[],nil)
- else
- p1:=sub_expr(oppower,[],nil);
- p1:=cunaryminusnode.create(p1);
- end;
- end;
- _OP_NOT :
- begin
- consume(_OP_NOT);
- p1:=factor(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,[]);
- 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;flags:texprflags;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 gettypedef(sym:tsym):tdef;inline;
- begin
- result:=nil;
- case sym.typ of
- typesym:
- result:=ttypesym(sym).typedef;
- procsym:
- if not (sp_generic_dummy in sym.symoptions) or (tprocsym(sym).procdeflist.count>0) then
- result:=tdef(tprocsym(sym).procdeflist[0]);
- else
- internalerror(2015092701);
- end;
- 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;
- calln:
- srsym:=tcallnode(n).symtableprocentry;
- specializen:
- srsym:=tspecializenode(n).sym;
- { TODO : handle const nodes }
- else
- ;
- end;
- result:=assigned(srsym);
- end;
- function generate_inline_specialization(gendef:tdef;n:tnode;filepos:tfileposinfo;parseddef:tdef;gensym:tsym;p2:tnode):tnode;
- var
- again,
- getaddr : boolean;
- pload : tnode;
- spezcontext : tspecializationcontext;
- structdef,
- inheriteddef : tabstractrecorddef;
- callflags : tcallnodeflags;
- begin
- if n.nodetype=specializen then
- begin
- getaddr:=tspecializenode(n).getaddr;
- pload:=tspecializenode(n).left;
- inheriteddef:=tabstractrecorddef(tspecializenode(n).inheriteddef);
- tspecializenode(n).left:=nil;
- end
- else
- begin
- getaddr:=false;
- pload:=nil;
- inheriteddef:=nil;
- end;
- if assigned(parseddef) and assigned(gensym) and assigned(p2) then
- gendef:=generate_specialization_phase1(spezcontext,gendef,parseddef,gensym.realname,gensym.owner,p2.fileinfo)
- else
- gendef:=generate_specialization_phase1(spezcontext,gendef);
- case gendef.typ of
- errordef:
- begin
- spezcontext.free;
- spezcontext:=nil;
- gensym:=generrorsym;
- end;
- objectdef,
- recorddef,
- procvardef,
- arraydef:
- begin
- gendef:=generate_specialization_phase2(spezcontext,tstoreddef(gendef),false,'');
- spezcontext.free;
- spezcontext:=nil;
- if gendef.typ=errordef then
- gensym:=generrorsym
- else
- gensym:=gendef.typesym;
- end;
- procdef:
- begin
- if block_type<>bt_body then
- begin
- message(parser_e_illegal_expression);
- gensym:=generrorsym;
- end
- else
- begin
- gensym:=tprocdef(gendef).procsym;
- end;
- end;
- else
- internalerror(2015092702);
- end;
- { in case of a class or a record the specialized generic
- is always a classrefdef }
- again:=false;
- if assigned(pload) then
- begin
- result:=pload;
- typecheckpass(result);
- structdef:=inheriteddef;
- if not assigned(structdef) then
- case result.resultdef.typ of
- objectdef,
- recorddef:
- begin
- structdef:=tabstractrecorddef(result.resultdef);
- end;
- classrefdef:
- begin
- structdef:=tabstractrecorddef(tclassrefdef(result.resultdef).pointeddef);
- end;
- else
- internalerror(2015092703);
- end;
- if not (structdef.typ in [recorddef,objectdef]) then
- internalerror(2018092101);
- if assigned(inheriteddef) then
- begin
- callflags:=[cnf_inherited];
- include(current_procinfo.flags,pi_has_inherited);
- end
- else
- callflags:=[];
- do_member_read(structdef,getaddr,gensym,result,again,callflags,spezcontext);
- spezcontext:=nil;
- end
- else
- begin
- if gensym.typ=procsym then
- begin
- result:=nil;
- { check if it's a method/class method }
- if is_member_read(gensym,gensym.owner,result,parseddef) then
- begin
- { if we are accessing a owner procsym from the nested }
- { class we need to call it as a class member }
- if (gensym.owner.symtabletype in [ObjectSymtable,recordsymtable]) and
- assigned(current_structdef) and (current_structdef<>parseddef) and is_owned_by(current_structdef,parseddef) then
- result:=cloadvmtaddrnode.create(ctypenode.create(parseddef));
- { not srsymtable.symtabletype since that can be }
- { withsymtable as well }
- if (gensym.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- begin
- do_member_read(tabstractrecorddef(parseddef),getaddr,gensym,result,again,[],spezcontext);
- spezcontext:=nil;
- end
- else
- { no procsyms in records (yet) }
- internalerror(2015092704);
- end
- else
- begin
- { regular procedure/function call }
- do_proc_call(gensym,gensym.owner,nil,
- (getaddr and not(token in [_CARET,_POINT,_LECKKLAMMER])),
- again,result,[],spezcontext);
- spezcontext:=nil;
- end;
- end
- else
- { handle potential typecasts, etc }
- result:=handle_factor_typenode(gendef,false,again,nil,false);
- end;
- { parse postfix operators }
- if postfixoperators(result,again,false) then
- if assigned(result) then
- result.fileinfo:=filepos
- else
- result:=cerrornode.create;
- spezcontext.free;
- end;
- label
- SubExprStart;
- var
- p1,p2,ptmp : tnode;
- oldt : Ttoken;
- filepos : tfileposinfo;
- gendef,parseddef : tdef;
- gensym : tsym;
- begin
- SubExprStart:
- if pred_level=highest_precedence then
- begin
- if factornode=nil then
- p1:=factor(false,flags)
- else
- p1:=factornode;
- end
- else
- p1:=sub_expr(succ(pred_level),flags+[ef_accept_equal],factornode);
- repeat
- if (token in [NOTOKEN..last_operator]) and
- (token in operator_levels[pred_level]) and
- ((token<>_EQ) or (ef_accept_equal in flags)) then
- begin
- oldt:=token;
- filepos:=current_tokenpos;
- consume(token);
- if pred_level=highest_precedence then
- p2:=factor(false,[])
- else
- p2:=sub_expr(succ(pred_level),flags+[ef_accept_equal],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 }
- if p1.nodetype=specializen then
- gendef:=gettypedef(tspecializenode(p1).sym)
- else
- gendef:=nil;
- parseddef:=gettypedef(p2);
- { check the hints for parseddef }
- check_hints(parseddef.typesym,parseddef.typesym.symoptions,parseddef.typesym.deprecatedmsg,p1.fileinfo);
- ptmp:=generate_inline_specialization(gendef,p1,filepos,parseddef,gensym,p2);
- { we don't need these nodes anymore }
- p1.free;
- p2.free;
- p1:=ptmp;
- { 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 (m_delphi in current_settings.modeswitches) and
- (token in [_LT, _LSHARPBRACKET]) and
- getgenericsym(p2,gensym) 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... }
- if gensym.typ=typesym then
- gendef:=ttypesym(gensym).typedef
- else
- if gensym.typ=procsym then
- gendef:=tdef(tprocsym(gensym).procdeflist[0])
- else
- internalerror(2015072401);
- ptmp:=generate_inline_specialization(gendef,p2,filepos,nil,nil,nil);
- { we don't need the old p2 anymore }
- p2.Free;
- p2:=ptmp;
- { 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);
- else
- internalerror(2019050528);
- 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_isolike_mod 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);
- else
- internalerror(2019050529);
- end;
- p1.fileinfo:=filepos;
- end
- else
- break;
- until false;
- sub_expr:=p1;
- end;
- function comp_expr(flags:texprflags):tnode;
- var
- oldafterassignment : boolean;
- p1 : tnode;
- begin
- oldafterassignment:=afterassignment;
- afterassignment:=true;
- p1:=sub_expr(opcompare,flags,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;
- oldflags : tnodeflags;
- begin
- oldafterassignment:=afterassignment;
- p1:=sub_expr(opcompare,[ef_accept_equal],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,[ef_accept_equal],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,[ef_accept_equal],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,[ef_accept_equal],nil);
- p1:=gen_c_style_operator(addn,p1,p2);
- end;
- _MINUSASN :
- begin
- consume(_MINUSASN);
- p2:=sub_expr(opcompare,[ef_accept_equal],nil);
- p1:=gen_c_style_operator(subn,p1,p2);
- end;
- _STARASN :
- begin
- consume(_STARASN );
- p2:=sub_expr(opcompare,[ef_accept_equal],nil);
- p1:=gen_c_style_operator(muln,p1,p2);
- end;
- _SLASHASN :
- begin
- consume(_SLASHASN );
- p2:=sub_expr(opcompare,[ef_accept_equal],nil);
- p1:=gen_c_style_operator(slashn,p1,p2);
- end;
- else
- updatefpos:=false;
- end;
- oldflags:=p1.flags;
- { get the resultdef for this expression }
- if not assigned(p1.resultdef) and
- dotypecheck then
- do_typecheckpass(p1);
- { transfer generic paramter flag }
- if nf_generic_para in oldflags then
- include(p1.flags,nf_generic_para);
- 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([ef_accept_equal]);
- 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([ef_accept_equal]);
- 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.
|