1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380 |
- {
- Copyright (c) 1998-2002 by Florian Klaempfl
- Type checking and register allocation for add nodes
- 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 nadd;
- {$i fpcdefs.inc}
- { define addstringopt}
- interface
- uses
- node,symtype;
- type
- taddnode = class(tbinopnode)
- resultrealtype : ttype;
- constructor create(tt : tnodetype;l,r : tnode);override;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- function simplify : tnode;override;
- {$ifdef state_tracking}
- function track_state_pass(exec_known:boolean):boolean;override;
- {$endif}
- protected
- { override the following if you want to implement }
- { parts explicitely in the code generator (JM) }
- function first_addstring: tnode; virtual;
- function first_addset: tnode; virtual;
- { only implements "muln" nodes, the rest always has to be done in }
- { the code generator for performance reasons (JM) }
- function first_add64bitint: tnode; virtual;
- { override and return false if you can handle 32x32->64 }
- { bit multiplies directly in your code generator. If }
- { this function is overridden to return false, you can }
- { get multiplies with left/right both s32bit or u32bit, }
- { and resulttype of the muln s64bit or u64bit }
- function use_generic_mul32to64: boolean; virtual;
- { This routine calls internal runtime library helpers
- for all floating point arithmetic in the case
- where the emulation switches is on. Otherwise
- returns nil, and everything must be done in
- the code generation phase.
- }
- function first_addfloat : tnode; virtual;
- private
- { checks whether a muln can be calculated as a 32bit }
- { * 32bit -> 64 bit }
- function try_make_mul32to64: boolean;
- end;
- taddnodeclass = class of taddnode;
- var
- { caddnode is used to create nodes of the add type }
- { the virtual constructor allows to assign }
- { another class type to caddnode => processor }
- { specific node types can be created }
- caddnode : taddnodeclass;
- implementation
- uses
- {$IFNDEF MACOS_USE_FAKE_SYSUTILS}
- sysutils,
- {$ENDIF MACOS_USE_FAKE_SYSUTILS}
- globtype,systems,
- cutils,verbose,globals,widestr,
- symconst,symdef,symsym,symtable,defutil,defcmp,
- cgbase,
- htypechk,pass_1,
- nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
- {$ifdef state_tracking}
- nstate,
- {$endif}
- cpuinfo,procinfo;
- {*****************************************************************************
- TADDNODE
- *****************************************************************************}
- {$ifdef fpc}
- {$maxfpuregisters 0}
- {$endif fpc}
- function getbestreal(const t1,t2 : ttype) : ttype;
- const
- floatweight : array[tfloattype] of byte =
- (2,3,4,0,1,5);
- begin
- if t1.def.deftype=floatdef then
- begin
- result:=t1;
- if t2.def.deftype=floatdef then
- begin
- { when a comp or currency is used, use always the
- best float type to calculate the result }
- if (tfloatdef(t2.def).typ in [s64comp,s64currency]) or
- (tfloatdef(t2.def).typ in [s64comp,s64currency]) then
- result:=pbestrealtype^
- else
- if floatweight[tfloatdef(t2.def).typ]>floatweight[tfloatdef(t1.def).typ] then
- result:=t2;
- end;
- end
- else if t2.def.deftype=floatdef then
- result:=t2
- else internalerror(200508061);
- end;
- constructor taddnode.create(tt : tnodetype;l,r : tnode);
- begin
- inherited create(tt,l,r);
- end;
- function taddnode.simplify : tnode;
- var
- t : tnode;
- lt,rt : tnodetype;
- rd,ld : tdef;
- rv,lv : tconstexprint;
- rvd,lvd : bestreal;
- ws1,ws2 : pcompilerwidestring;
- concatstrings : boolean;
- c1,c2 : array[0..1] of char;
- s1,s2 : pchar;
- l1,l2 : longint;
- resultset : Tconstset;
- b : boolean;
- begin
- result:=nil;
- { is one a real float, then both need to be floats, this
- need to be done before the constant folding so constant
- operation on a float and int are also handled }
- resultrealtype:=pbestrealtype^;
- if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then
- begin
- { when both floattypes are already equal then use that
- floattype for results }
- if (right.resulttype.def.deftype=floatdef) and
- (left.resulttype.def.deftype=floatdef) and
- (tfloatdef(left.resulttype.def).typ=tfloatdef(right.resulttype.def).typ) then
- resultrealtype:=left.resulttype
- { when there is a currency type then use currency, but
- only when currency is defined as float }
- else
- if (is_currency(right.resulttype.def) or
- is_currency(left.resulttype.def)) and
- ((s64currencytype.def.deftype = floatdef) or
- (nodetype <> slashn)) then
- begin
- resultrealtype:=s64currencytype;
- inserttypeconv(right,resultrealtype);
- inserttypeconv(left,resultrealtype);
- end
- else
- begin
- resultrealtype:=getbestreal(left.resulttype,right.resulttype);
- inserttypeconv(right,resultrealtype);
- inserttypeconv(left,resultrealtype);
- end;
- end;
- { If both operands are constant and there is a widechar
- or widestring then convert everything to widestring. This
- allows constant folding like char+widechar }
- if is_constnode(right) and is_constnode(left) and
- (is_widestring(right.resulttype.def) or
- is_widestring(left.resulttype.def) or
- is_widechar(right.resulttype.def) or
- is_widechar(left.resulttype.def)) then
- begin
- inserttypeconv(right,cwidestringtype);
- inserttypeconv(left,cwidestringtype);
- end;
- { load easier access variables }
- rd:=right.resulttype.def;
- ld:=left.resulttype.def;
- rt:=right.nodetype;
- lt:=left.nodetype;
- if (nodetype = slashn) and
- (((rt = ordconstn) and
- (tordconstnode(right).value = 0)) or
- ((rt = realconstn) and
- (trealconstnode(right).value_real = 0.0))) then
- begin
- if (cs_check_range in aktlocalswitches) or
- (cs_check_overflow in aktlocalswitches) then
- begin
- result:=crealconstnode.create(1,pbestrealtype^);
- Message(parser_e_division_by_zero);
- exit;
- end;
- end;
- { both are int constants }
- if (
- (
- is_constintnode(left) and
- is_constintnode(right)
- ) or
- (
- is_constboolnode(left) and
- is_constboolnode(right) and
- (nodetype in [slashn,ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])
- ) or
- (
- is_constenumnode(left) and
- is_constenumnode(right) and
- allowenumop(nodetype))
- ) or
- (
- (lt = pointerconstn) and
- is_constintnode(right) and
- (nodetype in [addn,subn])
- ) or
- (
- (lt in [pointerconstn,niln]) and
- (rt in [pointerconstn,niln]) and
- (nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])
- ) then
- begin
- t:=nil;
- { when comparing/substracting pointers, make sure they are }
- { of the same type (JM) }
- if (lt = pointerconstn) and (rt = pointerconstn) then
- begin
- if not(cs_extsyntax in aktmoduleswitches) and
- not(nodetype in [equaln,unequaln]) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename)
- else
- if (nodetype <> subn) and
- is_voidpointer(rd) then
- inserttypeconv(right,left.resulttype)
- else if (nodetype <> subn) and
- is_voidpointer(ld) then
- inserttypeconv(left,right.resulttype)
- else if not(equal_defs(ld,rd)) then
- IncompatibleTypes(ld,rd);
- end
- else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
- begin
- if not(equal_defs(ld,rd)) then
- inserttypeconv(right,left.resulttype);
- end;
- { load values }
- case lt of
- ordconstn:
- lv:=tordconstnode(left).value;
- pointerconstn:
- lv:=tpointerconstnode(left).value;
- niln:
- lv:=0;
- else
- internalerror(2002080202);
- end;
- case rt of
- ordconstn:
- rv:=tordconstnode(right).value;
- pointerconstn:
- rv:=tpointerconstnode(right).value;
- niln:
- rv:=0;
- else
- internalerror(2002080203);
- end;
- if (lt = pointerconstn) and
- (rt <> pointerconstn) then
- rv := rv * tpointerdef(left.resulttype.def).pointertype.def.size;
- if (rt = pointerconstn) and
- (lt <> pointerconstn) then
- lv := lv * tpointerdef(right.resulttype.def).pointertype.def.size;
- case nodetype of
- addn :
- begin
- {$ifopt Q-}
- {$define OVERFLOW_OFF}
- {$Q+}
- {$endif}
- try
- if (lt=pointerconstn) then
- t := cpointerconstnode.create(lv+rv,left.resulttype)
- else
- if is_integer(ld) then
- t := genintconstnode(lv+rv)
- else
- t := cordconstnode.create(lv+rv,left.resulttype,(ld.deftype<>enumdef));
- except
- on E:EIntOverflow do
- begin
- Message(parser_e_arithmetic_operation_overflow);
- { Recover }
- t:=genintconstnode(0)
- end;
- end;
- {$ifdef OVERFLOW_OFF}
- {$Q-}
- {$undef OVERFLOW_OFF}
- {$endif}
- end;
- subn :
- begin
- {$ifopt Q-}
- {$define OVERFLOW_OFF}
- {$Q+}
- {$endif}
- try
- if (lt=pointerconstn) then
- begin
- { pointer-pointer results in an integer }
- if (rt=pointerconstn) then
- t := genintconstnode((lv-rv) div tpointerdef(ld).pointertype.def.size)
- else
- t := cpointerconstnode.create(lv-rv,left.resulttype);
- end
- else
- begin
- if is_integer(ld) then
- t:=genintconstnode(lv-rv)
- else
- t:=cordconstnode.create(lv-rv,left.resulttype,(ld.deftype<>enumdef));
- end;
- except
- on E:EIntOverflow do
- begin
- Message(parser_e_arithmetic_operation_overflow);
- { Recover }
- t:=genintconstnode(0)
- end;
- end;
- {$ifdef OVERFLOW_OFF}
- {$Q-}
- {$undef OVERFLOW_OFF}
- {$endif}
- end;
- muln :
- begin
- {$ifopt Q-}
- {$define OVERFLOW_OFF}
- {$Q+}
- {$endif}
- try
- if (torddef(ld).typ <> u64bit) or
- (torddef(rd).typ <> u64bit) then
- t:=genintconstnode(lv*rv)
- else
- t:=genintconstnode(int64(qword(lv)*qword(rv)));
- except
- on E:EIntOverflow do
- begin
- Message(parser_e_arithmetic_operation_overflow);
- { Recover }
- t:=genintconstnode(0)
- end;
- end;
- {$ifdef OVERFLOW_OFF}
- {$Q-}
- {$undef OVERFLOW_OFF}
- {$endif}
- end;
- xorn :
- if is_integer(ld) then
- t:=genintconstnode(lv xor rv)
- else
- t:=cordconstnode.create(lv xor rv,left.resulttype,true);
- orn :
- if is_integer(ld) then
- t:=genintconstnode(lv or rv)
- else
- t:=cordconstnode.create(lv or rv,left.resulttype,true);
- andn :
- if is_integer(ld) then
- t:=genintconstnode(lv and rv)
- else
- t:=cordconstnode.create(lv and rv,left.resulttype,true);
- ltn :
- t:=cordconstnode.create(ord(lv<rv),booltype,true);
- lten :
- t:=cordconstnode.create(ord(lv<=rv),booltype,true);
- gtn :
- t:=cordconstnode.create(ord(lv>rv),booltype,true);
- gten :
- t:=cordconstnode.create(ord(lv>=rv),booltype,true);
- equaln :
- t:=cordconstnode.create(ord(lv=rv),booltype,true);
- unequaln :
- t:=cordconstnode.create(ord(lv<>rv),booltype,true);
- slashn :
- begin
- { int/int becomes a real }
- rvd:=rv;
- lvd:=lv;
- t:=crealconstnode.create(lvd/rvd,resultrealtype);
- end;
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- t:=cnothingnode.create;
- end;
- end;
- result:=t;
- exit;
- end;
- { both real constants ? }
- if (lt=realconstn) and (rt=realconstn) then
- begin
- lvd:=trealconstnode(left).value_real;
- rvd:=trealconstnode(right).value_real;
- case nodetype of
- addn :
- t:=crealconstnode.create(lvd+rvd,resultrealtype);
- subn :
- t:=crealconstnode.create(lvd-rvd,resultrealtype);
- muln :
- t:=crealconstnode.create(lvd*rvd,resultrealtype);
- starstarn,
- caretn :
- begin
- if lvd<0 then
- begin
- Message(parser_e_invalid_float_operation);
- t:=crealconstnode.create(0,resultrealtype);
- end
- else if lvd=0 then
- t:=crealconstnode.create(1.0,resultrealtype)
- else
- t:=crealconstnode.create(exp(ln(lvd)*rvd),resultrealtype);
- end;
- slashn :
- t:=crealconstnode.create(lvd/rvd,resultrealtype);
- ltn :
- t:=cordconstnode.create(ord(lvd<rvd),booltype,true);
- lten :
- t:=cordconstnode.create(ord(lvd<=rvd),booltype,true);
- gtn :
- t:=cordconstnode.create(ord(lvd>rvd),booltype,true);
- gten :
- t:=cordconstnode.create(ord(lvd>=rvd),booltype,true);
- equaln :
- t:=cordconstnode.create(ord(lvd=rvd),booltype,true);
- unequaln :
- t:=cordconstnode.create(ord(lvd<>rvd),booltype,true);
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- t:=cnothingnode.create;
- end;
- end;
- result:=t;
- exit;
- end;
- { first, we handle widestrings, so we can check later for }
- { stringconstn only }
- { widechars are converted above to widestrings too }
- { this isn't veryy efficient, but I don't think }
- { that it does matter that much (FK) }
- if (lt=stringconstn) and (rt=stringconstn) and
- (tstringconstnode(left).cst_type=cst_widestring) and
- (tstringconstnode(right).cst_type=cst_widestring) then
- begin
- initwidestring(ws1);
- initwidestring(ws2);
- copywidestring(pcompilerwidestring(tstringconstnode(left).value_str),ws1);
- copywidestring(pcompilerwidestring(tstringconstnode(right).value_str),ws2);
- case nodetype of
- addn :
- begin
- concatwidestrings(ws1,ws2);
- t:=cstringconstnode.createwstr(ws1);
- end;
- ltn :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype,true);
- lten :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype,true);
- gtn :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype,true);
- gten :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype,true);
- equaln :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype,true);
- unequaln :
- t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype,true);
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- t:=cnothingnode.create;
- end;
- end;
- donewidestring(ws1);
- donewidestring(ws2);
- result:=t;
- exit;
- end;
- { concating strings ? }
- concatstrings:=false;
- if (lt=ordconstn) and (rt=ordconstn) and
- is_char(ld) and is_char(rd) then
- begin
- c1[0]:=char(byte(tordconstnode(left).value));
- c1[1]:=#0;
- l1:=1;
- c2[0]:=char(byte(tordconstnode(right).value));
- c2[1]:=#0;
- l2:=1;
- s1:=@c1;
- s2:=@c2;
- concatstrings:=true;
- end
- else if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
- begin
- s1:=tstringconstnode(left).value_str;
- l1:=tstringconstnode(left).len;
- c2[0]:=char(byte(tordconstnode(right).value));
- c2[1]:=#0;
- s2:=@c2;
- l2:=1;
- concatstrings:=true;
- end
- else if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
- begin
- c1[0]:=char(byte(tordconstnode(left).value));
- c1[1]:=#0;
- l1:=1;
- s1:=@c1;
- s2:=tstringconstnode(right).value_str;
- l2:=tstringconstnode(right).len;
- concatstrings:=true;
- end
- else if (lt=stringconstn) and (rt=stringconstn) then
- begin
- s1:=tstringconstnode(left).value_str;
- l1:=tstringconstnode(left).len;
- s2:=tstringconstnode(right).value_str;
- l2:=tstringconstnode(right).len;
- concatstrings:=true;
- end;
- if concatstrings then
- begin
- case nodetype of
- addn :
- t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
- ltn :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype,true);
- lten :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype,true);
- gtn :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype,true);
- gten :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype,true);
- equaln :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype,true);
- unequaln :
- t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype,true);
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- t:=cnothingnode.create;
- end;
- end;
- result:=t;
- exit;
- end;
- { set constant evaluation }
- if (right.nodetype=setconstn) and
- not assigned(tsetconstnode(right).left) and
- (left.nodetype=setconstn) and
- not assigned(tsetconstnode(left).left) then
- begin
- { check if size adjusting is needed, only for left
- to right as the other way is checked in the typeconv }
- if (tsetdef(right.resulttype.def).settype=smallset) and
- (tsetdef(left.resulttype.def).settype<>smallset) then
- right.resulttype.setdef(tsetdef.create(tsetdef(right.resulttype.def).elementtype,255));
- { check base types }
- inserttypeconv(left,right.resulttype);
- if codegenerror then
- begin
- { recover by only returning the left part }
- result:=left;
- left:=nil;
- exit;
- end;
- case nodetype of
- addn :
- begin
- resultset:=tsetconstnode(right).value_set^ + tsetconstnode(left).value_set^;
- t:=csetconstnode.create(@resultset,left.resulttype);
- end;
- muln :
- begin
- resultset:=tsetconstnode(right).value_set^ * tsetconstnode(left).value_set^;
- t:=csetconstnode.create(@resultset,left.resulttype);
- end;
- subn :
- begin
- resultset:=tsetconstnode(left).value_set^ - tsetconstnode(right).value_set^;
- t:=csetconstnode.create(@resultset,left.resulttype);
- end;
- symdifn :
- begin
- resultset:=tsetconstnode(right).value_set^ >< tsetconstnode(left).value_set^;
- t:=csetconstnode.create(@resultset,left.resulttype);
- end;
- unequaln :
- begin
- b:=tsetconstnode(right).value_set^ <> tsetconstnode(left).value_set^;
- t:=cordconstnode.create(byte(b),booltype,true);
- end;
- equaln :
- begin
- b:=tsetconstnode(right).value_set^ = tsetconstnode(left).value_set^;
- t:=cordconstnode.create(byte(b),booltype,true);
- end;
- lten :
- begin
- b:=tsetconstnode(left).value_set^ <= tsetconstnode(right).value_set^;
- t:=cordconstnode.create(byte(b),booltype,true);
- end;
- gten :
- begin
- b:=tsetconstnode(left).value_set^ >= tsetconstnode(right).value_set^;
- t:=cordconstnode.create(byte(b),booltype,true);
- end;
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- t:=cnothingnode.create;
- end;
- end;
- result:=t;
- exit;
- end;
- end;
- function taddnode.det_resulttype:tnode;
- var
- hp : tnode;
- lt,rt : tnodetype;
- rd,ld : tdef;
- htype : ttype;
- ot : tnodetype;
- hsym : tfieldvarsym;
- i : longint;
- strtype : tstringtype;
- b : boolean;
- {$ifdef state_tracking}
- factval : Tnode;
- change : boolean;
- {$endif}
- begin
- result:=nil;
- { first do the two subtrees }
- resulttypepass(left);
- resulttypepass(right);
- { both left and right need to be valid }
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- set_varstate(right,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- { tp procvar support }
- maybe_call_procvar(left,true);
- maybe_call_procvar(right,true);
- { convert array constructors to sets, because there is no other operator
- possible for array constructors }
- if is_array_constructor(left.resulttype.def) then
- begin
- arrayconstructor_to_set(left);
- resulttypepass(left);
- end;
- if is_array_constructor(right.resulttype.def) then
- begin
- arrayconstructor_to_set(right);
- resulttypepass(right);
- end;
- { allow operator overloading }
- hp:=self;
- if isbinaryoverloaded(hp) then
- begin
- result:=hp;
- exit;
- end;
- { Stop checking when an error was found in the operator checking }
- if codegenerror then
- begin
- result:=cerrornode.create;
- exit;
- end;
- { Kylix allows enum+ordconstn in an enum declaration (blocktype
- is bt_type), we need to do the conversion here before the
- constant folding }
- if (m_delphi in aktmodeswitches) and
- (blocktype=bt_type) then
- begin
- if (left.resulttype.def.deftype=enumdef) and
- (right.resulttype.def.deftype=orddef) then
- begin
- { insert explicit typecast to default signed int }
- left:=ctypeconvnode.create_internal(left,sinttype);
- resulttypepass(left);
- end
- else
- if (left.resulttype.def.deftype=orddef) and
- (right.resulttype.def.deftype=enumdef) then
- begin
- { insert explicit typecast to default signed int }
- right:=ctypeconvnode.create_internal(right,sinttype);
- resulttypepass(right);
- end;
- end;
- result:=simplify;
- if assigned(result) then
- exit;
- { load easier access variables }
- rd:=right.resulttype.def;
- ld:=left.resulttype.def;
- rt:=right.nodetype;
- lt:=left.nodetype;
- { but an int/int gives real/real! }
- if nodetype=slashn then
- begin
- if is_currency(left.resulttype.def) and
- is_currency(right.resulttype.def) then
- { In case of currency, converting to float means dividing by 10000 }
- { However, since this is already a division, both divisions by }
- { 10000 are eliminated when we divide the results -> we can skip }
- { them. }
- if s64currencytype.def.deftype = floatdef then
- begin
- { there's no s64comptype or so, how do we avoid the type conversion?
- left.resulttype := s64comptype;
- right.resulttype := s64comptype; }
- end
- else
- begin
- left.resulttype := s64inttype;
- right.resulttype := s64inttype;
- end
- else if (left.resulttype.def.deftype <> floatdef) and
- (right.resulttype.def.deftype <> floatdef) then
- CGMessage(type_h_use_div_for_int);
- inserttypeconv(right,resultrealtype);
- inserttypeconv(left,resultrealtype);
- end
- { if both are orddefs then check sub types }
- else if (ld.deftype=orddef) and (rd.deftype=orddef) then
- begin
- { optimize multiplacation by a power of 2 }
- if not(cs_check_overflow in aktlocalswitches) and
- (nodetype = muln) and
- (((left.nodetype = ordconstn) and
- ispowerof2(tordconstnode(left).value,i)) or
- ((right.nodetype = ordconstn) and
- ispowerof2(tordconstnode(right).value,i))) then
- begin
- if left.nodetype = ordconstn then
- begin
- tordconstnode(left).value := i;
- result := cshlshrnode.create(shln,right,left);
- end
- else
- begin
- tordconstnode(right).value := i;
- result := cshlshrnode.create(shln,left,right);
- end;
- left := nil;
- right := nil;
- exit;
- end;
- { 2 booleans? Make them equal to the largest boolean }
- if is_boolean(ld) and is_boolean(rd) then
- begin
- if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then
- begin
- right:=ctypeconvnode.create_internal(right,left.resulttype);
- ttypeconvnode(right).convtype:=tc_bool_2_bool;
- resulttypepass(right);
- end
- else if torddef(left.resulttype.def).size<torddef(right.resulttype.def).size then
- begin
- left:=ctypeconvnode.create_internal(left,right.resulttype);
- ttypeconvnode(left).convtype:=tc_bool_2_bool;
- resulttypepass(left);
- end;
- case nodetype of
- xorn,
- ltn,
- lten,
- gtn,
- gten,
- andn,
- orn:
- begin
- end;
- unequaln,
- equaln:
- begin
- if not(cs_full_boolean_eval in aktlocalswitches) then
- begin
- { Remove any compares with constants }
- if (left.nodetype=ordconstn) then
- begin
- hp:=right;
- b:=(tordconstnode(left).value<>0);
- ot:=nodetype;
- left.free;
- left:=nil;
- right:=nil;
- if (not(b) and (ot=equaln)) or
- (b and (ot=unequaln)) then
- begin
- hp:=cnotnode.create(hp);
- end;
- result:=hp;
- exit;
- end;
- if (right.nodetype=ordconstn) then
- begin
- hp:=left;
- b:=(tordconstnode(right).value<>0);
- ot:=nodetype;
- right.free;
- right:=nil;
- left:=nil;
- if (not(b) and (ot=equaln)) or
- (b and (ot=unequaln)) then
- begin
- hp:=cnotnode.create(hp);
- end;
- result:=hp;
- exit;
- end;
- end;
- end;
- else
- begin
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- result:=cnothingnode.create;
- exit;
- end;
- end;
- end
- { Both are chars? }
- else if is_char(rd) and is_char(ld) then
- begin
- if nodetype=addn then
- begin
- resulttype:=cshortstringtype;
- if not(is_constcharnode(left) and is_constcharnode(right)) then
- begin
- inserttypeconv(left,cshortstringtype);
- {$ifdef addstringopt}
- hp := genaddsstringcharoptnode(self);
- result := hp;
- exit;
- {$endif addstringopt}
- end;
- end;
- end
- { There is a widechar? }
- else if is_widechar(rd) or is_widechar(ld) then
- begin
- { widechar+widechar gives widestring }
- if nodetype=addn then
- begin
- inserttypeconv(left,cwidestringtype);
- if (torddef(rd).typ<>uwidechar) then
- inserttypeconv(right,cwidechartype);
- resulttype:=cwidestringtype;
- end
- else
- begin
- if (torddef(ld).typ<>uwidechar) then
- inserttypeconv(left,cwidechartype);
- if (torddef(rd).typ<>uwidechar) then
- inserttypeconv(right,cwidechartype);
- end;
- end
- { is there a currency type ? }
- else if ((torddef(rd).typ=scurrency) or (torddef(ld).typ=scurrency)) then
- begin
- if (torddef(ld).typ<>scurrency) then
- inserttypeconv(left,s64currencytype);
- if (torddef(rd).typ<>scurrency) then
- inserttypeconv(right,s64currencytype);
- end
- { and,or,xor work on bit patterns and don't care
- about the sign of integers }
- else if (nodetype in [andn,orn,xorn]) and
- is_integer(ld) and is_integer(rd) then
- begin
- if rd.size>ld.size then
- inserttypeconv_internal(left,right.resulttype)
- else
- inserttypeconv_internal(right,left.resulttype);
- end
- { is there a signed 64 bit type ? }
- else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
- begin
- if (torddef(ld).typ<>s64bit) then
- inserttypeconv(left,s64inttype);
- if (torddef(rd).typ<>s64bit) then
- inserttypeconv(right,s64inttype);
- end
- { is there a unsigned 64 bit type ? }
- else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then
- begin
- if (torddef(ld).typ<>u64bit) then
- inserttypeconv(left,u64inttype);
- if (torddef(rd).typ<>u64bit) then
- inserttypeconv(right,u64inttype);
- end
- { 64 bit cpus do calculations always in 64 bit }
- {$ifndef cpu64bit}
- { is there a cardinal? }
- else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then
- begin
- { convert positive constants to u32bit }
- if (torddef(ld).typ<>u32bit) and
- is_constintnode(left) and
- (tordconstnode(left).value >= 0) then
- inserttypeconv(left,u32inttype);
- if (torddef(rd).typ<>u32bit) and
- is_constintnode(right) and
- (tordconstnode(right).value >= 0) then
- inserttypeconv(right,u32inttype);
- { when one of the operand is signed perform
- the operation in 64bit, can't use rd/ld here because there
- could be already typeconvs inserted }
- if is_signed(left.resulttype.def) or
- is_signed(right.resulttype.def) then
- begin
- CGMessage(type_w_mixed_signed_unsigned);
- inserttypeconv(left,s64inttype);
- inserttypeconv(right,s64inttype);
- end
- else
- begin
- if (torddef(left.resulttype.def).typ<>u32bit) then
- inserttypeconv(left,u32inttype);
- if (torddef(right.resulttype.def).typ<>u32bit) then
- inserttypeconv(right,u32inttype);
- end;
- end
- {$endif cpu64bit}
- { generic ord conversion is sinttype }
- else
- begin
- { if the left or right value is smaller than the normal
- type sinttype and is unsigned, and the other value
- is a constant < 0, the result will always be false/true
- for equal / unequal nodes.
- }
- if (
- { left : unsigned ordinal var, right : < 0 constant }
- (
- ((is_signed(ld)=false) and (is_constintnode(left) =false)) and
- ((is_constintnode(right)) and (tordconstnode(right).value < 0))
- ) or
- { right : unsigned ordinal var, left : < 0 constant }
- (
- ((is_signed(rd)=false) and (is_constintnode(right) =false)) and
- ((is_constintnode(left)) and (tordconstnode(left).value < 0))
- )
- ) then
- begin
- if nodetype = equaln then
- CGMessage(type_w_signed_unsigned_always_false)
- else
- if nodetype = unequaln then
- CGMessage(type_w_signed_unsigned_always_true)
- else
- if (is_constintnode(left) and (nodetype in [ltn,lten])) or
- (is_constintnode(right) and (nodetype in [gtn,gten])) then
- CGMessage(type_w_signed_unsigned_always_true)
- else
- if (is_constintnode(right) and (nodetype in [ltn,lten])) or
- (is_constintnode(left) and (nodetype in [gtn,gten])) then
- CGMessage(type_w_signed_unsigned_always_false);
- end;
- { When there is a signed type or there is a minus operation
- we convert to signed int. Otherwise (both are unsigned) we keep
- the result also unsigned. This is compatible with Delphi (PFV) }
- if is_signed(ld) or
- is_signed(rd) or
- (nodetype=subn) then
- begin
- inserttypeconv(right,sinttype);
- inserttypeconv(left,sinttype);
- end
- else
- begin
- inserttypeconv(right,uinttype);
- inserttypeconv(left,uinttype);
- end;
- end;
- end
- { if both are floatdefs, conversion is already done before constant folding }
- else if (ld.deftype=floatdef) then
- begin
- if not(nodetype in [addn,subn,muln,slashn,equaln,unequaln,ltn,lten,gtn,gten]) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { left side a setdef, must be before string processing,
- else array constructor can be seen as array of char (PFV) }
- else if (ld.deftype=setdef) then
- begin
- { trying to add a set element? }
- if (nodetype=addn) and (rd.deftype<>setdef) then
- begin
- if (rt=setelementn) then
- begin
- if not(equal_defs(tsetdef(ld).elementtype.def,rd)) then
- CGMessage(type_e_set_element_are_not_comp);
- end
- else
- CGMessage(type_e_mismatch)
- end
- else
- begin
- if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
- CGMessage(type_e_set_operation_unknown);
- { right def must be a also be set }
- if (rd.deftype<>setdef) or not(equal_defs(rd,ld)) then
- CGMessage(type_e_set_element_are_not_comp);
- end;
- { ranges require normsets }
- if (tsetdef(ld).settype=smallset) and
- (rt=setelementn) and
- assigned(tsetelementnode(right).right) then
- begin
- { generate a temporary normset def, it'll be destroyed
- when the symtable is unloaded }
- htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
- inserttypeconv(left,htype);
- end;
- { if the right side is also a setdef then the settype must
- be the same as the left setdef }
- if (rd.deftype=setdef) and
- (tsetdef(ld).settype<>tsetdef(rd).settype) then
- begin
- { when right is a normset we need to typecast both
- to normsets }
- if (tsetdef(rd).settype=normset) then
- inserttypeconv(left,right.resulttype)
- else
- inserttypeconv(right,left.resulttype);
- end;
- end
- { pointer comparision and subtraction }
- else if (
- (rd.deftype=pointerdef) and (ld.deftype=pointerdef)
- ) or
- { compare/add pchar to variable (not stringconst) char arrays
- by addresses like BP/Delphi }
- (
- (nodetype in [equaln,unequaln,subn,addn]) and
- (
- ((is_pchar(ld) or (lt=niln)) and is_chararray(rd) and (rt<>stringconstn)) or
- ((is_pchar(rd) or (rt=niln)) and is_chararray(ld) and (lt<>stringconstn))
- )
- ) then
- begin
- { convert char array to pointer }
- if is_chararray(rd) then
- begin
- inserttypeconv(right,charpointertype);
- rd:=right.resulttype.def;
- end
- else if is_chararray(ld) then
- begin
- inserttypeconv(left,charpointertype);
- ld:=left.resulttype.def;
- end;
- case nodetype of
- equaln,unequaln :
- begin
- if is_voidpointer(right.resulttype.def) then
- inserttypeconv(right,left.resulttype)
- else if is_voidpointer(left.resulttype.def) then
- inserttypeconv(left,right.resulttype)
- else if not(equal_defs(ld,rd)) then
- IncompatibleTypes(ld,rd);
- { now that the type checking is done, convert both to charpointer, }
- { because methodpointers are 8 bytes even though only the first 4 }
- { bytes must be compared. This can happen here if we are in }
- { TP/Delphi mode, because there @methodpointer = voidpointer (but }
- { a voidpointer of 8 bytes). A conversion to voidpointer would be }
- { optimized away, since the result already was a voidpointer, so }
- { use a charpointer instead (JM) }
- inserttypeconv_internal(left,charpointertype);
- inserttypeconv_internal(right,charpointertype);
- end;
- ltn,lten,gtn,gten:
- begin
- if (cs_extsyntax in aktmoduleswitches) then
- begin
- if is_voidpointer(right.resulttype.def) then
- inserttypeconv(right,left.resulttype)
- else if is_voidpointer(left.resulttype.def) then
- inserttypeconv(left,right.resulttype)
- else if not(equal_defs(ld,rd)) then
- IncompatibleTypes(ld,rd);
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end;
- subn:
- begin
- if (cs_extsyntax in aktmoduleswitches) then
- begin
- if is_voidpointer(right.resulttype.def) then
- inserttypeconv(right,left.resulttype)
- else if is_voidpointer(left.resulttype.def) then
- inserttypeconv(left,right.resulttype)
- else if not(equal_defs(ld,rd)) then
- IncompatibleTypes(ld,rd);
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- if not(nf_has_pointerdiv in flags) and
- (tpointerdef(rd).pointertype.def.size>1) then
- begin
- hp:=getcopy;
- include(hp.flags,nf_has_pointerdiv);
- result:=cmoddivnode.create(divn,hp,cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,false));
- end;
- resulttype:=sinttype;
- exit;
- end;
- addn:
- begin
- if (cs_extsyntax in aktmoduleswitches) then
- begin
- if is_voidpointer(right.resulttype.def) then
- inserttypeconv(right,left.resulttype)
- else if is_voidpointer(left.resulttype.def) then
- inserttypeconv(left,right.resulttype)
- else if not(equal_defs(ld,rd)) then
- IncompatibleTypes(ld,rd);
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- resulttype:=sinttype;
- exit;
- end;
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end;
- end
- { is one of the operands a string?,
- chararrays are also handled as strings (after conversion), also take
- care of chararray+chararray and chararray+char.
- Note: Must be done after pointerdef+pointerdef has been checked, else
- pchar is converted to string }
- else if (rd.deftype=stringdef) or
- (ld.deftype=stringdef) or
- ((is_pchar(rd) or is_chararray(rd) or is_char(rd) or is_open_chararray(rd) or
- is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd)) and
- (is_pchar(ld) or is_chararray(ld) or is_char(ld) or is_open_chararray(ld) or
- is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld))) then
- begin
- if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
- begin
- { Is there a widestring? }
- if is_widestring(rd) or is_widestring(ld) or
- is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd) or
- is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld) then
- strtype:= st_widestring
- else
- if is_ansistring(rd) or is_ansistring(ld) or
- ((cs_ansistrings in aktlocalswitches) and
- //todo: Move some of this to longstring's then they are implemented?
- (
- is_pchar(rd) or (is_chararray(rd) and (rd.size > 255)) or is_open_chararray(rd) or
- is_pchar(ld) or (is_chararray(ld) and (ld.size > 255)) or is_open_chararray(ld)
- )
- ) then
- strtype:= st_ansistring
- else
- if is_longstring(rd) or is_longstring(ld) then
- strtype:= st_longstring
- else
- begin
- {$warning todo: add a warning/hint here if one converting a too large array}
- { nodes is PChar, array [with size > 255] or OpenArrayOfChar.
- Note: Delphi halts with error if "array [0..xx] of char"
- is assigned to ShortString and string length is less
- then array size }
- strtype:= st_shortstring;
- end;
- // Now convert nodes to common string type
- case strtype of
- st_widestring :
- begin
- if not(is_widestring(rd)) then
- inserttypeconv(right,cwidestringtype);
- if not(is_widestring(ld)) then
- inserttypeconv(left,cwidestringtype);
- end;
- st_ansistring :
- begin
- if not(is_ansistring(rd)) then
- inserttypeconv(right,cansistringtype);
- if not(is_ansistring(ld)) then
- inserttypeconv(left,cansistringtype);
- end;
- st_longstring :
- begin
- if not(is_longstring(rd)) then
- inserttypeconv(right,clongstringtype);
- if not(is_longstring(ld)) then
- inserttypeconv(left,clongstringtype);
- end;
- st_shortstring :
- begin
- if not(is_shortstring(ld)) then
- inserttypeconv(left,cshortstringtype);
- { don't convert char, that can be handled by the optimized node }
- if not(is_shortstring(rd) or is_char(rd)) then
- inserttypeconv(right,cshortstringtype);
- end;
- else
- internalerror(2005101);
- end;
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { class or interface equation }
- else if is_class_or_interface(rd) or is_class_or_interface(ld) then
- begin
- if (nodetype in [equaln,unequaln]) then
- begin
- if is_class_or_interface(rd) and is_class_or_interface(ld) then
- begin
- if tobjectdef(rd).is_related(tobjectdef(ld)) then
- inserttypeconv(right,left.resulttype)
- else
- inserttypeconv(left,right.resulttype);
- end
- else if is_class_or_interface(rd) then
- inserttypeconv(left,right.resulttype)
- else
- inserttypeconv(right,left.resulttype);
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
- begin
- if (nodetype in [equaln,unequaln]) then
- begin
- if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
- tobjectdef(tclassrefdef(ld).pointertype.def)) then
- inserttypeconv(right,left.resulttype)
- else
- inserttypeconv(left,right.resulttype);
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { allows comperasion with nil pointer }
- else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
- begin
- if (nodetype in [equaln,unequaln]) then
- inserttypeconv(left,right.resulttype)
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
- begin
- if (nodetype in [equaln,unequaln]) then
- inserttypeconv(right,left.resulttype)
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { support procvar=nil,procvar<>nil }
- else if ((ld.deftype=procvardef) and (rt=niln)) or
- ((rd.deftype=procvardef) and (lt=niln)) then
- begin
- if not(nodetype in [equaln,unequaln]) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- { find proc field in methodpointer record }
- hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
- if not assigned(hsym) then
- internalerror(200412043);
- { For methodpointers compare only tmethodpointer.proc }
- if (rd.deftype=procvardef) and
- (not tprocvardef(rd).is_addressonly) then
- begin
- right:=csubscriptnode.create(
- hsym,
- ctypeconvnode.create_internal(right,methodpointertype));
- end;
- if (ld.deftype=procvardef) and
- (not tprocvardef(ld).is_addressonly) then
- begin
- left:=csubscriptnode.create(
- hsym,
- ctypeconvnode.create_internal(left,methodpointertype));
- end;
- end
- { support dynamicarray=nil,dynamicarray<>nil }
- else if (is_dynamic_array(ld) and (rt=niln)) or
- (is_dynamic_array(rd) and (lt=niln)) or
- (is_dynamic_array(ld) and is_dynamic_array(rd)) then
- begin
- if not(nodetype in [equaln,unequaln]) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- {$ifdef SUPPORT_MMX}
- { mmx support, this must be before the zero based array
- check }
- else if (cs_mmx in aktlocalswitches) and
- is_mmx_able_array(ld) and
- is_mmx_able_array(rd) and
- equal_defs(ld,rd) then
- begin
- case nodetype of
- addn,subn,xorn,orn,andn:
- ;
- { mul is a little bit restricted }
- muln:
- if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end;
- end
- {$endif SUPPORT_MMX}
- { this is a little bit dangerous, also the left type }
- { pointer to should be checked! This broke the mmx support }
- else if (rd.deftype=pointerdef) or
- (is_zero_based_array(rd) and (rt<>stringconstn)) then
- begin
- if is_zero_based_array(rd) then
- begin
- resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
- inserttypeconv(right,resulttype);
- end
- else
- resulttype:=right.resulttype;
- inserttypeconv(left,sinttype);
- if nodetype=addn then
- begin
- if not(cs_extsyntax in aktmoduleswitches) or
- (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- if (rd.deftype=pointerdef) and
- (tpointerdef(rd).pointertype.def.size>1) then
- begin
- left:=caddnode.create(muln,left,
- cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,true));
- end;
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- else if (ld.deftype=pointerdef) or
- (is_zero_based_array(ld) and (lt<>stringconstn)) then
- begin
- if is_zero_based_array(ld) then
- begin
- resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
- inserttypeconv(left,resulttype);
- end
- else
- resulttype:=left.resulttype;
- inserttypeconv(right,sinttype);
- if nodetype in [addn,subn] then
- begin
- if not(cs_extsyntax in aktmoduleswitches) or
- (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- if (ld.deftype=pointerdef) and
- (tpointerdef(ld).pointertype.def.size>1) then
- begin
- right:=caddnode.create(muln,right,
- cordconstnode.create(tpointerdef(ld).pointertype.def.size,sinttype,true));
- end
- else
- if is_zero_based_array(ld) and
- (tarraydef(ld).elementtype.def.size>1) then
- begin
- right:=caddnode.create(muln,right,
- cordconstnode.create(tarraydef(ld).elementtype.def.size,sinttype,true));
- end;
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- else if (rd.deftype=procvardef) and
- (ld.deftype=procvardef) and
- equal_defs(rd,ld) then
- begin
- if (nodetype in [equaln,unequaln]) then
- begin
- if tprocvardef(rd).is_addressonly then
- begin
- inserttypeconv_internal(right,voidpointertype);
- inserttypeconv_internal(left,voidpointertype);
- end
- else
- begin
- { find proc field in methodpointer record }
- hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
- if not assigned(hsym) then
- internalerror(200412043);
- { Compare tmehodpointer(left).proc }
- right:=csubscriptnode.create(
- hsym,
- ctypeconvnode.create_internal(right,methodpointertype));
- left:=csubscriptnode.create(
- hsym,
- ctypeconvnode.create_internal(left,methodpointertype));
- end;
- end
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { enums }
- else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
- begin
- if allowenumop(nodetype) then
- inserttypeconv(right,left.resulttype)
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
- end
- { generic conversion, this is for error recovery }
- else
- begin
- inserttypeconv(left,sinttype);
- inserttypeconv(right,sinttype);
- end;
- { set resulttype if not already done }
- if not assigned(resulttype.def) then
- begin
- case nodetype of
- ltn,lten,gtn,gten,equaln,unequaln :
- resulttype:=booltype;
- slashn :
- resulttype:=resultrealtype;
- addn:
- begin
- { for strings, return is always a 255 char string }
- if is_shortstring(left.resulttype.def) then
- resulttype:=cshortstringtype
- else
- resulttype:=left.resulttype;
- end;
- else
- resulttype:=left.resulttype;
- end;
- end;
- { when the result is currency we need some extra code for
- multiplication and division. this should not be done when
- the muln or slashn node is created internally }
- if not(nf_is_currency in flags) and
- is_currency(resulttype.def) then
- begin
- case nodetype of
- slashn :
- begin
- { slashn will only work with floats }
- hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,s64currencytype));
- include(hp.flags,nf_is_currency);
- result:=hp;
- end;
- muln :
- begin
- if s64currencytype.def.deftype=floatdef then
- hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype))
- else
- hp:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,s64currencytype,false));
- include(hp.flags,nf_is_currency);
- result:=hp
- end;
- end;
- end;
- end;
- function taddnode.first_addstring: tnode;
- var
- p: tnode;
- begin
- { when we get here, we are sure that both the left and the right }
- { node are both strings of the same stringtype (JM) }
- case nodetype of
- addn:
- begin
- { create the call to the concat routine both strings as arguments }
- result := ccallnode.createintern('fpc_'+
- tstringdef(resulttype.def).stringtypname+'_concat',
- ccallparanode.create(right,ccallparanode.create(left,nil)));
- { we reused the arguments }
- left := nil;
- right := nil;
- end;
- ltn,lten,gtn,gten,equaln,unequaln :
- begin
- { generate better code for comparison with empty string, we
- only need to compare the length with 0 }
- if (nodetype in [equaln,unequaln,gtn,gten,ltn,lten]) and
- (((left.nodetype=stringconstn) and (tstringconstnode(left).len=0)) or
- ((right.nodetype=stringconstn) and (tstringconstnode(right).len=0))) then
- begin
- { switch so that the constant is always on the right }
- if left.nodetype = stringconstn then
- begin
- p := left;
- left := right;
- right := p;
- end;
- if is_shortstring(left.resulttype.def) or
- (nodetype in [gtn,gten,ltn,lten]) then
- { compare the length with 0 }
- result := caddnode.create(nodetype,
- cinlinenode.create(in_length_x,false,left),
- cordconstnode.create(0,s32inttype,false))
- else
- begin
- { compare the pointer with nil (for ansistrings etc), }
- { faster than getting the length (JM) }
- result:= caddnode.create(nodetype,
- ctypeconvnode.create_internal(left,voidpointertype),
- cpointerconstnode.create(0,voidpointertype));
- end;
- { left is reused }
- left := nil;
- { right isn't }
- right.free;
- right := nil;
- exit;
- end;
- { no string constant -> call compare routine }
- result := ccallnode.createintern('fpc_'+
- tstringdef(left.resulttype.def).stringtypname+'_compare',
- ccallparanode.create(right,ccallparanode.create(left,nil)));
- { and compare its result with 0 according to the original operator }
- result := caddnode.create(nodetype,result,
- cordconstnode.create(0,s32inttype,false));
- left := nil;
- right := nil;
- end;
- end;
- end;
- function taddnode.first_addset: tnode;
- var
- procname: string[31];
- tempn: tnode;
- paras: tcallparanode;
- srsym: ttypesym;
- begin
- { get the sym that represents the fpc_normal_set type }
- srsym:=search_system_type('FPC_NORMAL_SET');
- case nodetype of
- equaln,unequaln,lten,gten:
- begin
- case nodetype of
- equaln,unequaln:
- procname := 'fpc_set_comp_sets';
- lten,gten:
- begin
- procname := 'fpc_set_contains_sets';
- { (left >= right) = (right <= left) }
- if nodetype = gten then
- begin
- tempn := left;
- left := right;
- right := tempn;
- end;
- end;
- end;
- { convert the arguments (explicitely) to fpc_normal_set's }
- left := ctypeconvnode.create_internal(left,srsym.restype);
- right := ctypeconvnode.create_internal(right,srsym.restype);
- result := ccallnode.createintern(procname,ccallparanode.create(right,
- ccallparanode.create(left,nil)));
- { left and right are reused as parameters }
- left := nil;
- right := nil;
- { for an unequaln, we have to negate the result of comp_sets }
- if nodetype = unequaln then
- result := cnotnode.create(result);
- end;
- addn:
- begin
- { optimize first loading of a set }
- if (right.nodetype=setelementn) and
- not(assigned(tsetelementnode(right).right)) and
- is_emptyset(left) then
- begin
- { type cast the value to pass as argument to a byte, }
- { since that's what the helper expects }
- tsetelementnode(right).left :=
- ctypeconvnode.create_internal(tsetelementnode(right).left,u8inttype);
- { set the resulttype to the actual one (otherwise it's }
- { "fpc_normal_set") }
- result := ccallnode.createinternres('fpc_set_create_element',
- ccallparanode.create(tsetelementnode(right).left,nil),
- resulttype);
- { reused }
- tsetelementnode(right).left := nil;
- end
- else
- begin
- if right.nodetype=setelementn then
- begin
- { convert the arguments to bytes, since that's what }
- { the helper expects }
- tsetelementnode(right).left :=
- ctypeconvnode.create_internal(tsetelementnode(right).left,
- u8inttype);
- { convert the original set (explicitely) to an }
- { fpc_normal_set so we can pass it to the helper }
- left := ctypeconvnode.create_internal(left,srsym.restype);
- { add a range or a single element? }
- if assigned(tsetelementnode(right).right) then
- begin
- tsetelementnode(right).right :=
- ctypeconvnode.create_internal(tsetelementnode(right).right,
- u8inttype);
- { create the call }
- result := ccallnode.createinternres('fpc_set_set_range',
- ccallparanode.create(tsetelementnode(right).right,
- ccallparanode.create(tsetelementnode(right).left,
- ccallparanode.create(left,nil))),resulttype);
- end
- else
- begin
- result := ccallnode.createinternres('fpc_set_set_byte',
- ccallparanode.create(tsetelementnode(right).left,
- ccallparanode.create(left,nil)),resulttype);
- end;
- { remove reused parts from original node }
- tsetelementnode(right).right := nil;
- tsetelementnode(right).left := nil;
- left := nil;
- end
- else
- begin
- { add two sets }
- { convert the sets to fpc_normal_set's }
- result := ccallnode.createinternres('fpc_set_add_sets',
- ccallparanode.create(
- ctypeconvnode.create_explicit(right,srsym.restype),
- ccallparanode.create(
- ctypeconvnode.create_internal(left,srsym.restype),nil)),resulttype);
- { remove reused parts from original node }
- left := nil;
- right := nil;
- end;
- end
- end;
- subn,symdifn,muln:
- begin
- { convert the sets to fpc_normal_set's }
- paras := ccallparanode.create(ctypeconvnode.create_internal(right,srsym.restype),
- ccallparanode.create(ctypeconvnode.create_internal(left,srsym.restype),nil));
- case nodetype of
- subn:
- result := ccallnode.createinternres('fpc_set_sub_sets',
- paras,resulttype);
- symdifn:
- result := ccallnode.createinternres('fpc_set_symdif_sets',
- paras,resulttype);
- muln:
- result := ccallnode.createinternres('fpc_set_mul_sets',
- paras,resulttype);
- end;
- { remove reused parts from original node }
- left := nil;
- right := nil;
- end;
- else
- internalerror(200108311);
- end;
- end;
- function taddnode.use_generic_mul32to64: boolean;
- begin
- result := true;
- end;
- function taddnode.try_make_mul32to64: boolean;
- function canbe32bitint(v: tconstexprint; fromdef: torddef; todefsigned: boolean): boolean;
- begin
- if (fromdef.typ <> u64bit) then
- result :=
- ((v >= 0) or
- todefsigned) and
- (v >= low(longint)) and
- (v <= high(longint))
- else
- result :=
- (qword(v) >= low(cardinal)) and
- (qword(v) <= high(cardinal))
- end;
- var
- temp: tnode;
- begin
- result := false;
- if ((left.nodetype = typeconvn) and
- is_integer(ttypeconvnode(left).left.resulttype.def) and
- (not(torddef(ttypeconvnode(left).left.resulttype.def).typ in [u64bit,s64bit])) and
- (((right.nodetype = ordconstn) and
- canbe32bitint(tordconstnode(right).value,torddef(right.resulttype.def),is_signed(left.resulttype.def))) or
- ((right.nodetype = typeconvn) and
- is_integer(ttypeconvnode(right).left.resulttype.def) and
- not(torddef(ttypeconvnode(right).left.resulttype.def).typ in [u64bit,s64bit])) and
- (is_signed(ttypeconvnode(left).left.resulttype.def) =
- is_signed(ttypeconvnode(right).left.resulttype.def)))) then
- begin
- temp := ttypeconvnode(left).left;
- ttypeconvnode(left).left := nil;
- left.free;
- left := temp;
- if (right.nodetype = typeconvn) then
- begin
- temp := ttypeconvnode(right).left;
- ttypeconvnode(right).left := nil;
- right.free;
- right := temp;
- end;
- if (is_signed(left.resulttype.def)) then
- begin
- inserttypeconv(left,s32inttype);
- inserttypeconv(right,s32inttype);
- end
- else
- begin
- inserttypeconv(left,u32inttype);
- inserttypeconv(right,u32inttype);
- end;
- firstpass(left);
- firstpass(right);
- result := true;
- end;
- end;
- function taddnode.first_add64bitint: tnode;
- var
- procname: string[31];
- temp: tnode;
- power: longint;
- begin
- result := nil;
- { create helper calls mul }
- if nodetype <> muln then
- exit;
- { make sure that if there is a constant, that it's on the right }
- if left.nodetype = ordconstn then
- begin
- temp := right;
- right := left;
- left := temp;
- end;
- { can we use a shift instead of a mul? }
- if not (cs_check_overflow in aktlocalswitches) and
- (right.nodetype = ordconstn) and
- ispowerof2(tordconstnode(right).value,power) then
- begin
- tordconstnode(right).value := power;
- result := cshlshrnode.create(shln,left,right);
- { left and right are reused }
- left := nil;
- right := nil;
- { return firstpassed new node }
- exit;
- end;
- if not(use_generic_mul32to64) and
- try_make_mul32to64 then
- exit;
- { when currency is used set the result of the
- parameters to s64bit, so they are not converted }
- if is_currency(resulttype.def) then
- begin
- left.resulttype:=s64inttype;
- right.resulttype:=s64inttype;
- end;
- { otherwise, create the parameters for the helper }
- right := ccallparanode.create(
- cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype,true),
- ccallparanode.create(right,ccallparanode.create(left,nil)));
- left := nil;
- { only qword needs the unsigned code, the
- signed code is also used for currency }
- if is_signed(resulttype.def) then
- procname := 'fpc_mul_int64'
- else
- procname := 'fpc_mul_qword';
- result := ccallnode.createintern(procname,right);
- right := nil;
- end;
- function taddnode.first_addfloat : tnode;
- var
- procname: string[31];
- { do we need to reverse the result ? }
- notnode : boolean;
- begin
- result := nil;
- notnode := false;
- { In non-emulation mode, real opcodes are
- emitted for floating point values.
- }
- if not (cs_fp_emulation in aktmoduleswitches) then
- exit;
- if not(target_info.system in system_wince) then
- begin
- case tfloatdef(left.resulttype.def).typ of
- s32real:
- procname:='float32';
- s64real:
- procname:='float64';
- {!!! not yet implemented
- s128real:
- }
- else
- internalerror(2005082601);
- end;
- case nodetype of
- addn:
- procname:=procname+'_add';
- muln:
- procname:=procname+'_mul';
- subn:
- procname:=procname+'_sub';
- slashn:
- procname:=procname+'_div';
- ltn:
- procname:=procname+'_lt';
- lten:
- procname:=procname+'_le';
- gtn:
- begin
- procname:=procname+'_le';
- notnode:=true;
- end;
- gten:
- begin
- procname:=procname+'_lt';
- notnode:=true;
- end;
- equaln:
- procname:=procname+'_eq';
- unequaln:
- begin
- procname:=procname+'_eq';
- notnode:=true;
- end;
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
- end;
- end
- else
- begin
- case nodetype of
- addn:
- procname:='ADD';
- muln:
- procname:='MUL';
- subn:
- procname:='SUB';
- slashn:
- procname:='DIV';
- ltn:
- procname:='LT';
- lten:
- procname:='LE';
- gtn:
- procname:='GT';
- gten:
- procname:='GE';
- equaln:
- procname:='EQ';
- unequaln:
- procname:='NE';
- else
- CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
- end;
- case tfloatdef(left.resulttype.def).typ of
- s32real:
- procname:=procname+'S';
- s64real:
- procname:=procname+'D';
- {!!! not yet implemented
- s128real:
- }
- else
- internalerror(2005082602);
- end;
- end;
- result:=ccallnode.createintern(procname,ccallparanode.create(right,
- ccallparanode.create(left,nil)));
- left:=nil;
- right:=nil;
- { do we need to reverse the result }
- if notnode then
- result:=cnotnode.create(result);
- end;
- function taddnode.pass_1 : tnode;
- var
- {$ifdef addstringopt}
- hp : tnode;
- {$endif addstringopt}
- lt,rt : tnodetype;
- rd,ld : tdef;
- begin
- result:=nil;
- { Can we optimize multiple string additions into a single call?
- This need to be done on a complete tree to detect the multiple
- add nodes and is therefor done before the subtrees are processed }
- if canbemultistringadd(self) then
- begin
- result := genmultistringadd(self);
- exit;
- end;
- { first do the two subtrees }
- firstpass(left);
- firstpass(right);
- if codegenerror then
- exit;
- { load easier access variables }
- rd:=right.resulttype.def;
- ld:=left.resulttype.def;
- rt:=right.nodetype;
- lt:=left.nodetype;
- { int/int gives real/real! }
- if nodetype=slashn then
- begin
- {$ifdef cpufpemu}
- if (aktfputype=fpu_soft) or (cs_fp_emulation in aktmoduleswitches) then
- begin
- result:=first_addfloat;
- if assigned(result) then
- exit;
- end;
- {$endif cpufpemu}
- expectloc:=LOC_FPUREGISTER;
- { maybe we need an integer register to save }
- { a reference }
- if ((left.expectloc<>LOC_FPUREGISTER) or
- (right.expectloc<>LOC_FPUREGISTER)) and
- (left.registersint=right.registersint) then
- calcregisters(self,1,1,0)
- else
- calcregisters(self,0,1,0);
- { an add node always first loads both the left and the }
- { right in the fpu before doing the calculation. However, }
- { calcregisters(0,2,0) will overestimate the number of }
- { necessary registers (it will make it 3 in case one of }
- { the operands is already in the fpu) (JM) }
- if ((left.expectloc<>LOC_FPUREGISTER) or
- (right.expectloc<>LOC_FPUREGISTER)) and
- (registersfpu < 2) then
- inc(registersfpu);
- end
- { if both are orddefs then check sub types }
- else if (ld.deftype=orddef) and (rd.deftype=orddef) then
- begin
- { 2 booleans ? }
- if is_boolean(ld) and is_boolean(rd) then
- begin
- if not(cs_full_boolean_eval in aktlocalswitches) and
- (nodetype in [andn,orn]) then
- begin
- expectloc:=LOC_JUMP;
- calcregisters(self,0,0,0);
- end
- else
- begin
- if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
- begin
- expectloc:=LOC_FLAGS;
- if (left.expectloc in [LOC_JUMP,LOC_FLAGS]) and
- (left.expectloc in [LOC_JUMP,LOC_FLAGS]) then
- calcregisters(self,2,0,0)
- else
- calcregisters(self,1,0,0);
- end
- else
- begin
- expectloc:=LOC_REGISTER;
- calcregisters(self,0,0,0);
- end;
- end;
- end
- else
- { Both are chars? only convert to shortstrings for addn }
- if is_char(ld) then
- begin
- if nodetype=addn then
- internalerror(200103291);
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- {$ifndef cpu64bit}
- { is there a 64 bit type ? }
- else if (torddef(ld).typ in [s64bit,u64bit,scurrency]) then
- begin
- result := first_add64bitint;
- if assigned(result) then
- exit;
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_REGISTER
- else
- expectloc:=LOC_JUMP;
- calcregisters(self,2,0,0)
- end
- {$endif cpu64bit}
- { is there a cardinal? }
- else if (torddef(ld).typ=u32bit) then
- begin
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_REGISTER
- else
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- { for unsigned mul we need an extra register }
- if nodetype=muln then
- inc(registersint);
- end
- { generic s32bit conversion }
- else
- begin
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_REGISTER
- else
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end;
- end
- { left side a setdef, must be before string processing,
- else array constructor can be seen as array of char (PFV) }
- else if (ld.deftype=setdef) then
- begin
- if tsetdef(ld).settype=smallset then
- begin
- if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
- expectloc:=LOC_FLAGS
- else
- expectloc:=LOC_REGISTER;
- { are we adding set elements ? }
- if right.nodetype=setelementn then
- calcregisters(self,2,0,0)
- else
- calcregisters(self,1,0,0);
- end
- else
- {$ifdef MMXSET}
- {$ifdef i386}
- if cs_mmx in aktlocalswitches then
- begin
- expectloc:=LOC_MMXREGISTER;
- calcregisters(self,0,0,4);
- end
- else
- {$endif}
- {$endif MMXSET}
- begin
- result := first_addset;
- if assigned(result) then
- exit;
- expectloc:=LOC_CREFERENCE;
- calcregisters(self,0,0,0);
- { here we call SET... }
- include(current_procinfo.flags,pi_do_call);
- end;
- end
- { compare pchar by addresses like BP/Delphi }
- else if is_pchar(ld) then
- begin
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_REGISTER
- else
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- { is one of the operands a string }
- else if (ld.deftype=stringdef) then
- begin
- if is_widestring(ld) then
- begin
- { this is only for add, the comparisaion is handled later }
- expectloc:=LOC_REGISTER;
- end
- else if is_ansistring(ld) then
- begin
- { this is only for add, the comparisaion is handled later }
- expectloc:=LOC_REGISTER;
- end
- else if is_longstring(ld) then
- begin
- { this is only for add, the comparisaion is handled later }
- expectloc:=LOC_REFERENCE;
- end
- else
- begin
- {$ifdef addstringopt}
- { can create a call which isn't handled by callparatemp }
- if canbeaddsstringcharoptnode(self) then
- begin
- hp := genaddsstringcharoptnode(self);
- pass_1 := hp;
- exit;
- end
- else
- {$endif addstringopt}
- begin
- { Fix right to be shortstring }
- if is_char(right.resulttype.def) then
- begin
- inserttypeconv(right,cshortstringtype);
- firstpass(right);
- end;
- end;
- {$ifdef addstringopt}
- { can create a call which isn't handled by callparatemp }
- if canbeaddsstringcsstringoptnode(self) then
- begin
- hp := genaddsstringcsstringoptnode(self);
- pass_1 := hp;
- exit;
- end;
- {$endif addstringopt}
- end;
- { otherwise, let addstring convert everything }
- result := first_addstring;
- exit;
- end
- { is one a real float ? }
- else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
- begin
- {$ifdef cpufpemu}
- if (aktfputype=fpu_soft) or (cs_fp_emulation in aktmoduleswitches) then
- begin
- result:=first_addfloat;
- if assigned(result) then
- exit;
- end;
- {$endif cpufpemu}
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_FPUREGISTER
- else
- expectloc:=LOC_FLAGS;
- calcregisters(self,0,1,0);
- { an add node always first loads both the left and the }
- { right in the fpu before doing the calculation. However, }
- { calcregisters(0,2,0) will overestimate the number of }
- { necessary registers (it will make it 3 in case one of }
- { the operands is already in the fpu) (JM) }
- if ((left.expectloc<>LOC_FPUREGISTER) or
- (right.expectloc<>LOC_FPUREGISTER)) and
- (registersfpu < 2) then
- inc(registersfpu);
- end
- { pointer comperation and subtraction }
- else if (ld.deftype=pointerdef) then
- begin
- if nodetype in [addn,subn,muln,andn,orn,xorn] then
- expectloc:=LOC_REGISTER
- else
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- else if is_class_or_interface(ld) then
- begin
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- else if (ld.deftype=classrefdef) then
- begin
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- { support procvar=nil,procvar<>nil }
- else if ((ld.deftype=procvardef) and (rt=niln)) or
- ((rd.deftype=procvardef) and (lt=niln)) then
- begin
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- {$ifdef SUPPORT_MMX}
- { mmx support, this must be before the zero based array
- check }
- else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
- is_mmx_able_array(rd) then
- begin
- expectloc:=LOC_MMXREGISTER;
- calcregisters(self,0,0,1);
- end
- {$endif SUPPORT_MMX}
- else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
- begin
- expectloc:=LOC_REGISTER;
- calcregisters(self,1,0,0);
- end
- else if (rd.deftype=procvardef) and
- (ld.deftype=procvardef) and
- equal_defs(rd,ld) then
- begin
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- else if (ld.deftype=enumdef) then
- begin
- expectloc:=LOC_FLAGS;
- calcregisters(self,1,0,0);
- end
- {$ifdef SUPPORT_MMX}
- else if (cs_mmx in aktlocalswitches) and
- is_mmx_able_array(ld) and
- is_mmx_able_array(rd) then
- begin
- expectloc:=LOC_MMXREGISTER;
- calcregisters(self,0,0,1);
- end
- {$endif SUPPORT_MMX}
- { the general solution is to convert to 32 bit int }
- else
- begin
- expectloc:=LOC_REGISTER;
- calcregisters(self,1,0,0);
- end;
- end;
- {$ifdef state_tracking}
- function Taddnode.track_state_pass(exec_known:boolean):boolean;
- var factval:Tnode;
- begin
- track_state_pass:=false;
- if left.track_state_pass(exec_known) then
- begin
- track_state_pass:=true;
- left.resulttype.def:=nil;
- do_resulttypepass(left);
- end;
- factval:=aktstate.find_fact(left);
- if factval<>nil then
- begin
- track_state_pass:=true;
- left.destroy;
- left:=factval.getcopy;
- end;
- if right.track_state_pass(exec_known) then
- begin
- track_state_pass:=true;
- right.resulttype.def:=nil;
- do_resulttypepass(right);
- end;
- factval:=aktstate.find_fact(right);
- if factval<>nil then
- begin
- track_state_pass:=true;
- right.destroy;
- right:=factval.getcopy;
- end;
- end;
- {$endif}
- begin
- caddnode:=taddnode;
- end.
|