nadd.pas 90 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Type checking and register allocation for add nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit nadd;
  19. {$i fpcdefs.inc}
  20. { define addstringopt}
  21. interface
  22. uses
  23. node;
  24. type
  25. taddnode = class(tbinopnode)
  26. constructor create(tt : tnodetype;l,r : tnode);override;
  27. function pass_1 : tnode;override;
  28. function det_resulttype:tnode;override;
  29. {$ifdef state_tracking}
  30. function track_state_pass(exec_known:boolean):boolean;override;
  31. {$endif}
  32. protected
  33. { override the following if you want to implement }
  34. { parts explicitely in the code generator (JM) }
  35. function first_addstring: tnode; virtual;
  36. function first_addset: tnode; virtual;
  37. { only implements "muln" nodes, the rest always has to be done in }
  38. { the code generator for performance reasons (JM) }
  39. function first_add64bitint: tnode; virtual;
  40. {$ifdef cpufpemu}
  41. { This routine calls internal runtime library helpers
  42. for all floating point arithmetic in the case
  43. where the emulation switches is on. Otherwise
  44. returns nil, and everything must be done in
  45. the code generation phase.
  46. }
  47. function first_addfloat : tnode; virtual;
  48. {$endif cpufpemu}
  49. end;
  50. taddnodeclass = class of taddnode;
  51. var
  52. { caddnode is used to create nodes of the add type }
  53. { the virtual constructor allows to assign }
  54. { another class type to caddnode => processor }
  55. { specific node types can be created }
  56. caddnode : taddnodeclass;
  57. implementation
  58. uses
  59. globtype,systems,
  60. cutils,verbose,globals,widestr,
  61. symconst,symtype,symdef,symsym,symtable,defutil,defcmp,
  62. cgbase,
  63. htypechk,pass_1,
  64. nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
  65. {$ifdef state_tracking}
  66. nstate,
  67. {$endif}
  68. cpuinfo,procinfo;
  69. {*****************************************************************************
  70. TADDNODE
  71. *****************************************************************************}
  72. {$ifdef fpc}
  73. {$maxfpuregisters 0}
  74. {$endif fpc}
  75. constructor taddnode.create(tt : tnodetype;l,r : tnode);
  76. begin
  77. inherited create(tt,l,r);
  78. end;
  79. function taddnode.det_resulttype:tnode;
  80. var
  81. hp,t : tnode;
  82. lt,rt : tnodetype;
  83. rd,ld : tdef;
  84. htype : ttype;
  85. ot : tnodetype;
  86. concatstrings : boolean;
  87. resultset : Tconstset;
  88. i : longint;
  89. b : boolean;
  90. c1,c2 :char;
  91. s1,s2 : pchar;
  92. ws1,ws2 : pcompilerwidestring;
  93. l1,l2 : longint;
  94. rv,lv : tconstexprint;
  95. rvd,lvd : bestreal;
  96. resultrealtype : ttype;
  97. {$ifdef state_tracking}
  98. factval : Tnode;
  99. change : boolean;
  100. {$endif}
  101. begin
  102. result:=nil;
  103. { first do the two subtrees }
  104. resulttypepass(left);
  105. resulttypepass(right);
  106. { both left and right need to be valid }
  107. set_varstate(left,vs_used,true);
  108. set_varstate(right,vs_used,true);
  109. if codegenerror then
  110. exit;
  111. { tp procvar support }
  112. maybe_call_procvar(left,true);
  113. maybe_call_procvar(right,true);
  114. { convert array constructors to sets, because there is no other operator
  115. possible for array constructors }
  116. if is_array_constructor(left.resulttype.def) then
  117. begin
  118. arrayconstructor_to_set(left);
  119. resulttypepass(left);
  120. end;
  121. if is_array_constructor(right.resulttype.def) then
  122. begin
  123. arrayconstructor_to_set(right);
  124. resulttypepass(right);
  125. end;
  126. { allow operator overloading }
  127. hp:=self;
  128. if isbinaryoverloaded(hp) then
  129. begin
  130. result:=hp;
  131. exit;
  132. end;
  133. { Stop checking when an error was found in the operator checking }
  134. if codegenerror then
  135. begin
  136. result:=cerrornode.create;
  137. exit;
  138. end;
  139. { Kylix allows enum+ordconstn in an enum declaration (blocktype
  140. is bt_type), we need to do the conversion here before the
  141. constant folding }
  142. if (m_delphi in aktmodeswitches) and
  143. (blocktype=bt_type) then
  144. begin
  145. if (left.resulttype.def.deftype=enumdef) and
  146. (right.resulttype.def.deftype=orddef) then
  147. begin
  148. { insert explicit typecast to default signed int }
  149. left:=ctypeconvnode.create_explicit(left,sinttype);
  150. resulttypepass(left);
  151. end
  152. else
  153. if (left.resulttype.def.deftype=orddef) and
  154. (right.resulttype.def.deftype=enumdef) then
  155. begin
  156. { insert explicit typecast to default signed int }
  157. right:=ctypeconvnode.create_explicit(right,sinttype);
  158. resulttypepass(right);
  159. end;
  160. end;
  161. { is one a real float, then both need to be floats, this
  162. need to be done before the constant folding so constant
  163. operation on a float and int are also handled }
  164. resultrealtype:=pbestrealtype^;
  165. if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then
  166. begin
  167. { when both floattypes are already equal then use that
  168. floattype for results }
  169. if (right.resulttype.def.deftype=floatdef) and
  170. (left.resulttype.def.deftype=floatdef) and
  171. (tfloatdef(left.resulttype.def).typ=tfloatdef(right.resulttype.def).typ) then
  172. resultrealtype:=left.resulttype
  173. { when there is a currency type then use currency, but
  174. only when currency is defined as float }
  175. else
  176. if (is_currency(right.resulttype.def) or
  177. is_currency(left.resulttype.def)) and
  178. ((s64currencytype.def.deftype = floatdef) or
  179. (nodetype <> slashn)) then
  180. begin
  181. resultrealtype:=s64currencytype;
  182. inserttypeconv(right,resultrealtype);
  183. inserttypeconv(left,resultrealtype);
  184. end
  185. else
  186. begin
  187. inserttypeconv(right,resultrealtype);
  188. inserttypeconv(left,resultrealtype);
  189. end;
  190. end;
  191. { if one operand is a widechar or a widestring, both operands }
  192. { are converted to widestring. This must be done before constant }
  193. { folding to allow char+widechar etc. }
  194. if is_widestring(right.resulttype.def) or
  195. is_widestring(left.resulttype.def) or
  196. is_widechar(right.resulttype.def) or
  197. is_widechar(left.resulttype.def) then
  198. begin
  199. inserttypeconv(right,cwidestringtype);
  200. inserttypeconv(left,cwidestringtype);
  201. end;
  202. { load easier access variables }
  203. rd:=right.resulttype.def;
  204. ld:=left.resulttype.def;
  205. rt:=right.nodetype;
  206. lt:=left.nodetype;
  207. if (nodetype = slashn) and
  208. (((rt = ordconstn) and
  209. (tordconstnode(right).value = 0)) or
  210. ((rt = realconstn) and
  211. (trealconstnode(right).value_real = 0.0))) then
  212. begin
  213. if (cs_check_range in aktlocalswitches) or
  214. (cs_check_overflow in aktlocalswitches) then
  215. begin
  216. result:=crealconstnode.create(1,pbestrealtype^);
  217. Message(parser_e_division_by_zero);
  218. exit;
  219. end;
  220. end;
  221. { both are int constants }
  222. if ((is_constintnode(left) and is_constintnode(right)) or
  223. (is_constboolnode(left) and is_constboolnode(right) and
  224. (nodetype in [slashn,ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])) or
  225. (is_constenumnode(left) and is_constenumnode(right) and
  226. (nodetype in [equaln,unequaln,ltn,lten,gtn,gten]))) or
  227. { support pointer arithmetics on constants (JM) }
  228. ((lt = pointerconstn) and is_constintnode(right) and
  229. (nodetype in [addn,subn])) or
  230. (((lt = pointerconstn) or (lt = niln)) and
  231. ((rt = pointerconstn) or (rt = niln)) and
  232. (nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])) then
  233. begin
  234. { when comparing/substracting pointers, make sure they are }
  235. { of the same type (JM) }
  236. if (lt = pointerconstn) and (rt = pointerconstn) then
  237. begin
  238. if not(cs_extsyntax in aktmoduleswitches) and
  239. not(nodetype in [equaln,unequaln]) then
  240. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename)
  241. else
  242. if (nodetype <> subn) and
  243. is_voidpointer(rd) then
  244. inserttypeconv(right,left.resulttype)
  245. else if (nodetype <> subn) and
  246. is_voidpointer(ld) then
  247. inserttypeconv(left,right.resulttype)
  248. else if not(equal_defs(ld,rd)) then
  249. IncompatibleTypes(ld,rd);
  250. end
  251. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  252. begin
  253. if not(equal_defs(ld,rd)) then
  254. inserttypeconv(right,left.resulttype);
  255. end;
  256. { load values }
  257. case lt of
  258. ordconstn:
  259. lv:=tordconstnode(left).value;
  260. pointerconstn:
  261. lv:=tpointerconstnode(left).value;
  262. niln:
  263. lv:=0;
  264. else
  265. internalerror(2002080202);
  266. end;
  267. case rt of
  268. ordconstn:
  269. rv:=tordconstnode(right).value;
  270. pointerconstn:
  271. rv:=tpointerconstnode(right).value;
  272. niln:
  273. rv:=0;
  274. else
  275. internalerror(2002080203);
  276. end;
  277. if (lt = pointerconstn) and
  278. (rt <> pointerconstn) then
  279. rv := rv * tpointerdef(left.resulttype.def).pointertype.def.size;
  280. if (rt = pointerconstn) and
  281. (lt <> pointerconstn) then
  282. lv := lv * tpointerdef(right.resulttype.def).pointertype.def.size;
  283. case nodetype of
  284. addn :
  285. if (lt <> pointerconstn) then
  286. t := genintconstnode(lv+rv)
  287. else
  288. t := cpointerconstnode.create(lv+rv,left.resulttype);
  289. subn :
  290. if (lt=pointerconstn) and (rt=pointerconstn) and
  291. (tpointerdef(rd).pointertype.def.size>1) then
  292. t := genintconstnode((lv-rv) div tpointerdef(left.resulttype.def).pointertype.def.size)
  293. else if (lt <> pointerconstn) or (rt = pointerconstn) then
  294. t := genintconstnode(lv-rv)
  295. else
  296. t := cpointerconstnode.create(lv-rv,left.resulttype);
  297. muln :
  298. if (torddef(ld).typ <> u64bit) or
  299. (torddef(rd).typ <> u64bit) then
  300. t:=genintconstnode(lv*rv)
  301. else
  302. t:=genintconstnode(int64(qword(lv)*qword(rv)));
  303. xorn :
  304. if is_integer(ld) then
  305. t:=genintconstnode(lv xor rv)
  306. else
  307. t:=cordconstnode.create(lv xor rv,left.resulttype,true);
  308. orn :
  309. if is_integer(ld) then
  310. t:=genintconstnode(lv or rv)
  311. else
  312. t:=cordconstnode.create(lv or rv,left.resulttype,true);
  313. andn :
  314. if is_integer(ld) then
  315. t:=genintconstnode(lv and rv)
  316. else
  317. t:=cordconstnode.create(lv and rv,left.resulttype,true);
  318. ltn :
  319. t:=cordconstnode.create(ord(lv<rv),booltype,true);
  320. lten :
  321. t:=cordconstnode.create(ord(lv<=rv),booltype,true);
  322. gtn :
  323. t:=cordconstnode.create(ord(lv>rv),booltype,true);
  324. gten :
  325. t:=cordconstnode.create(ord(lv>=rv),booltype,true);
  326. equaln :
  327. t:=cordconstnode.create(ord(lv=rv),booltype,true);
  328. unequaln :
  329. t:=cordconstnode.create(ord(lv<>rv),booltype,true);
  330. slashn :
  331. begin
  332. { int/int becomes a real }
  333. rvd:=rv;
  334. lvd:=lv;
  335. t:=crealconstnode.create(lvd/rvd,resultrealtype);
  336. end;
  337. else
  338. begin
  339. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  340. t:=cnothingnode.create;
  341. end;
  342. end;
  343. result:=t;
  344. exit;
  345. end;
  346. { both real constants ? }
  347. if (lt=realconstn) and (rt=realconstn) then
  348. begin
  349. lvd:=trealconstnode(left).value_real;
  350. rvd:=trealconstnode(right).value_real;
  351. case nodetype of
  352. addn :
  353. t:=crealconstnode.create(lvd+rvd,resultrealtype);
  354. subn :
  355. t:=crealconstnode.create(lvd-rvd,resultrealtype);
  356. muln :
  357. t:=crealconstnode.create(lvd*rvd,resultrealtype);
  358. starstarn,
  359. caretn :
  360. begin
  361. if lvd<0 then
  362. begin
  363. Message(parser_e_invalid_float_operation);
  364. t:=crealconstnode.create(0,resultrealtype);
  365. end
  366. else if lvd=0 then
  367. t:=crealconstnode.create(1.0,resultrealtype)
  368. else
  369. t:=crealconstnode.create(exp(ln(lvd)*rvd),resultrealtype);
  370. end;
  371. slashn :
  372. t:=crealconstnode.create(lvd/rvd,resultrealtype);
  373. ltn :
  374. t:=cordconstnode.create(ord(lvd<rvd),booltype,true);
  375. lten :
  376. t:=cordconstnode.create(ord(lvd<=rvd),booltype,true);
  377. gtn :
  378. t:=cordconstnode.create(ord(lvd>rvd),booltype,true);
  379. gten :
  380. t:=cordconstnode.create(ord(lvd>=rvd),booltype,true);
  381. equaln :
  382. t:=cordconstnode.create(ord(lvd=rvd),booltype,true);
  383. unequaln :
  384. t:=cordconstnode.create(ord(lvd<>rvd),booltype,true);
  385. else
  386. begin
  387. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  388. t:=cnothingnode.create;
  389. end;
  390. end;
  391. result:=t;
  392. exit;
  393. end;
  394. { first, we handle widestrings, so we can check later for }
  395. { stringconstn only }
  396. { widechars are converted above to widestrings too }
  397. { this isn't veryy efficient, but I don't think }
  398. { that it does matter that much (FK) }
  399. if (lt=stringconstn) and (rt=stringconstn) and
  400. (tstringconstnode(left).st_type=st_widestring) and
  401. (tstringconstnode(right).st_type=st_widestring) then
  402. begin
  403. initwidestring(ws1);
  404. initwidestring(ws2);
  405. copywidestring(pcompilerwidestring(tstringconstnode(left).value_str),ws1);
  406. copywidestring(pcompilerwidestring(tstringconstnode(right).value_str),ws2);
  407. case nodetype of
  408. addn :
  409. begin
  410. concatwidestrings(ws1,ws2);
  411. t:=cstringconstnode.createwstr(ws1);
  412. end;
  413. ltn :
  414. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype,true);
  415. lten :
  416. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype,true);
  417. gtn :
  418. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype,true);
  419. gten :
  420. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype,true);
  421. equaln :
  422. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype,true);
  423. unequaln :
  424. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype,true);
  425. else
  426. begin
  427. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  428. t:=cnothingnode.create;
  429. end;
  430. end;
  431. donewidestring(ws1);
  432. donewidestring(ws2);
  433. result:=t;
  434. exit;
  435. end;
  436. { concating strings ? }
  437. concatstrings:=false;
  438. if (lt=ordconstn) and (rt=ordconstn) and
  439. is_char(ld) and is_char(rd) then
  440. begin
  441. c1:=char(byte(tordconstnode(left).value));
  442. l1:=1;
  443. c2:=char(byte(tordconstnode(right).value));
  444. l2:=1;
  445. s1:=@c1;
  446. s2:=@c2;
  447. concatstrings:=true;
  448. end
  449. else if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
  450. begin
  451. s1:=tstringconstnode(left).value_str;
  452. l1:=tstringconstnode(left).len;
  453. c2:=char(byte(tordconstnode(right).value));
  454. s2:=@c2;
  455. l2:=1;
  456. concatstrings:=true;
  457. end
  458. else if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
  459. begin
  460. c1:=char(byte(tordconstnode(left).value));
  461. l1:=1;
  462. s1:=@c1;
  463. s2:=tstringconstnode(right).value_str;
  464. l2:=tstringconstnode(right).len;
  465. concatstrings:=true;
  466. end
  467. else if (lt=stringconstn) and (rt=stringconstn) then
  468. begin
  469. s1:=tstringconstnode(left).value_str;
  470. l1:=tstringconstnode(left).len;
  471. s2:=tstringconstnode(right).value_str;
  472. l2:=tstringconstnode(right).len;
  473. concatstrings:=true;
  474. end;
  475. if concatstrings then
  476. begin
  477. case nodetype of
  478. addn :
  479. t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
  480. ltn :
  481. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype,true);
  482. lten :
  483. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype,true);
  484. gtn :
  485. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype,true);
  486. gten :
  487. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype,true);
  488. equaln :
  489. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype,true);
  490. unequaln :
  491. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype,true);
  492. end;
  493. result:=t;
  494. exit;
  495. end;
  496. { set constant evaluation }
  497. if (right.nodetype=setconstn) and
  498. not assigned(tsetconstnode(right).left) and
  499. (left.nodetype=setconstn) and
  500. not assigned(tsetconstnode(left).left) then
  501. begin
  502. { check if size adjusting is needed, only for left
  503. to right as the other way is checked in the typeconv }
  504. if (tsetdef(right.resulttype.def).settype=smallset) and
  505. (tsetdef(left.resulttype.def).settype<>smallset) then
  506. right.resulttype.setdef(tsetdef.create(tsetdef(right.resulttype.def).elementtype,255));
  507. { check base types }
  508. inserttypeconv(left,right.resulttype);
  509. if codegenerror then
  510. begin
  511. { recover by only returning the left part }
  512. result:=left;
  513. left:=nil;
  514. exit;
  515. end;
  516. case nodetype of
  517. addn :
  518. begin
  519. resultset:=tsetconstnode(right).value_set^ + tsetconstnode(left).value_set^;
  520. t:=csetconstnode.create(@resultset,left.resulttype);
  521. end;
  522. muln :
  523. begin
  524. resultset:=tsetconstnode(right).value_set^ * tsetconstnode(left).value_set^;
  525. t:=csetconstnode.create(@resultset,left.resulttype);
  526. end;
  527. subn :
  528. begin
  529. resultset:=tsetconstnode(left).value_set^ - tsetconstnode(right).value_set^;
  530. t:=csetconstnode.create(@resultset,left.resulttype);
  531. end;
  532. symdifn :
  533. begin
  534. resultset:=tsetconstnode(right).value_set^ >< tsetconstnode(left).value_set^;
  535. t:=csetconstnode.create(@resultset,left.resulttype);
  536. end;
  537. unequaln :
  538. begin
  539. b:=tsetconstnode(right).value_set^ <> tsetconstnode(left).value_set^;
  540. t:=cordconstnode.create(byte(b),booltype,true);
  541. end;
  542. equaln :
  543. begin
  544. b:=tsetconstnode(right).value_set^ = tsetconstnode(left).value_set^;
  545. t:=cordconstnode.create(byte(b),booltype,true);
  546. end;
  547. lten :
  548. begin
  549. b:=tsetconstnode(left).value_set^ <= tsetconstnode(right).value_set^;
  550. t:=cordconstnode.create(byte(b),booltype,true);
  551. end;
  552. gten :
  553. begin
  554. b:=tsetconstnode(left).value_set^ >= tsetconstnode(right).value_set^;
  555. t:=cordconstnode.create(byte(b),booltype,true);
  556. end;
  557. end;
  558. result:=t;
  559. exit;
  560. end;
  561. { but an int/int gives real/real! }
  562. if nodetype=slashn then
  563. begin
  564. if is_currency(left.resulttype.def) and
  565. is_currency(right.resulttype.def) then
  566. { In case of currency, converting to float means dividing by 10000 }
  567. { However, since this is already a division, both divisions by }
  568. { 10000 are eliminated when we divide the results -> we can skip }
  569. { them. }
  570. if s64currencytype.def.deftype = floatdef then
  571. begin
  572. { there's no s64comptype or so, how do we avoid the type conversion?
  573. left.resulttype := s64comptype;
  574. right.resulttype := s64comptype; }
  575. end
  576. else
  577. begin
  578. left.resulttype := s64inttype;
  579. right.resulttype := s64inttype;
  580. end
  581. else if (left.resulttype.def.deftype <> floatdef) and
  582. (right.resulttype.def.deftype <> floatdef) then
  583. CGMessage(type_h_use_div_for_int);
  584. inserttypeconv(right,resultrealtype);
  585. inserttypeconv(left,resultrealtype);
  586. end
  587. { if both are orddefs then check sub types }
  588. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  589. begin
  590. { optimize multiplacation by a power of 2 }
  591. if not(cs_check_overflow in aktlocalswitches) and
  592. (nodetype = muln) and
  593. (((left.nodetype = ordconstn) and
  594. ispowerof2(tordconstnode(left).value,i)) or
  595. ((right.nodetype = ordconstn) and
  596. ispowerof2(tordconstnode(right).value,i))) then
  597. begin
  598. if left.nodetype = ordconstn then
  599. begin
  600. tordconstnode(left).value := i;
  601. result := cshlshrnode.create(shln,right,left);
  602. end
  603. else
  604. begin
  605. tordconstnode(right).value := i;
  606. result := cshlshrnode.create(shln,left,right);
  607. end;
  608. left := nil;
  609. right := nil;
  610. exit;
  611. end;
  612. { 2 booleans? Make them equal to the largest boolean }
  613. if is_boolean(ld) and is_boolean(rd) then
  614. begin
  615. if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then
  616. begin
  617. right:=ctypeconvnode.create_explicit(right,left.resulttype);
  618. ttypeconvnode(right).convtype:=tc_bool_2_int;
  619. resulttypepass(right);
  620. end
  621. else if torddef(left.resulttype.def).size<torddef(right.resulttype.def).size then
  622. begin
  623. left:=ctypeconvnode.create_explicit(left,right.resulttype);
  624. ttypeconvnode(left).convtype:=tc_bool_2_int;
  625. resulttypepass(left);
  626. end;
  627. case nodetype of
  628. xorn,
  629. ltn,
  630. lten,
  631. gtn,
  632. gten,
  633. andn,
  634. orn:
  635. begin
  636. end;
  637. unequaln,
  638. equaln:
  639. begin
  640. if not(cs_full_boolean_eval in aktlocalswitches) then
  641. begin
  642. { Remove any compares with constants }
  643. if (left.nodetype=ordconstn) then
  644. begin
  645. hp:=right;
  646. b:=(tordconstnode(left).value<>0);
  647. ot:=nodetype;
  648. left.free;
  649. left:=nil;
  650. right:=nil;
  651. if (not(b) and (ot=equaln)) or
  652. (b and (ot=unequaln)) then
  653. begin
  654. hp:=cnotnode.create(hp);
  655. end;
  656. result:=hp;
  657. exit;
  658. end;
  659. if (right.nodetype=ordconstn) then
  660. begin
  661. hp:=left;
  662. b:=(tordconstnode(right).value<>0);
  663. ot:=nodetype;
  664. right.free;
  665. right:=nil;
  666. left:=nil;
  667. if (not(b) and (ot=equaln)) or
  668. (b and (ot=unequaln)) then
  669. begin
  670. hp:=cnotnode.create(hp);
  671. end;
  672. result:=hp;
  673. exit;
  674. end;
  675. end;
  676. end;
  677. else
  678. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  679. end;
  680. end
  681. { Both are chars? }
  682. else if is_char(rd) and is_char(ld) then
  683. begin
  684. if nodetype=addn then
  685. begin
  686. resulttype:=cshortstringtype;
  687. if not(is_constcharnode(left) and is_constcharnode(right)) then
  688. begin
  689. inserttypeconv(left,cshortstringtype);
  690. {$ifdef addstringopt}
  691. hp := genaddsstringcharoptnode(self);
  692. result := hp;
  693. exit;
  694. {$endif addstringopt}
  695. end;
  696. end;
  697. end
  698. { is there a currency type ? }
  699. else if ((torddef(rd).typ=scurrency) or (torddef(ld).typ=scurrency)) then
  700. begin
  701. if (torddef(ld).typ<>scurrency) then
  702. inserttypeconv(left,s64currencytype);
  703. if (torddef(rd).typ<>scurrency) then
  704. inserttypeconv(right,s64currencytype);
  705. end
  706. { is there a signed 64 bit type ? }
  707. else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
  708. begin
  709. if (torddef(ld).typ<>s64bit) then
  710. inserttypeconv(left,s64inttype);
  711. if (torddef(rd).typ<>s64bit) then
  712. inserttypeconv(right,s64inttype);
  713. end
  714. { is there a unsigned 64 bit type ? }
  715. else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then
  716. begin
  717. if (torddef(ld).typ<>u64bit) then
  718. inserttypeconv(left,u64inttype);
  719. if (torddef(rd).typ<>u64bit) then
  720. inserttypeconv(right,u64inttype);
  721. end
  722. { 64 bit cpus do calculations always in 64 bit }
  723. {$ifndef cpu64bit}
  724. { is there a cardinal? }
  725. else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then
  726. begin
  727. { and,or,xor work on bit patterns and don't care
  728. about the sign }
  729. if nodetype in [andn,orn,xorn] then
  730. begin
  731. inserttypeconv_explicit(left,u32inttype);
  732. inserttypeconv_explicit(right,u32inttype);
  733. end
  734. else
  735. begin
  736. { convert positive constants to u32bit }
  737. if (torddef(ld).typ<>u32bit) and
  738. is_constintnode(left) and
  739. (tordconstnode(left).value >= 0) then
  740. inserttypeconv(left,u32inttype);
  741. if (torddef(rd).typ<>u32bit) and
  742. is_constintnode(right) and
  743. (tordconstnode(right).value >= 0) then
  744. inserttypeconv(right,u32inttype);
  745. { when one of the operand is signed perform
  746. the operation in 64bit }
  747. if is_signed(ld) or is_signed(rd) then
  748. begin
  749. CGMessage(type_w_mixed_signed_unsigned);
  750. inserttypeconv(left,s64inttype);
  751. inserttypeconv(right,s64inttype);
  752. end
  753. else
  754. begin
  755. if (torddef(ld).typ<>u32bit) then
  756. inserttypeconv(left,u32inttype);
  757. if (torddef(rd).typ<>u32bit) then
  758. inserttypeconv(right,u32inttype);
  759. end;
  760. end;
  761. end
  762. {$endif cpu64bit}
  763. { generic ord conversion is sinttype }
  764. else
  765. begin
  766. { if the left or right value is smaller than the normal
  767. type s32inttype and is unsigned, and the other value
  768. is a constant < 0, the result will always be false/true
  769. for equal / unequal nodes.
  770. }
  771. if (
  772. { left : unsigned ordinal var, right : < 0 constant }
  773. (
  774. ((is_signed(ld)=false) and (is_constintnode(left) =false)) and
  775. ((is_constintnode(right)) and (tordconstnode(right).value < 0))
  776. ) or
  777. { right : unsigned ordinal var, left : < 0 constant }
  778. (
  779. ((is_signed(rd)=false) and (is_constintnode(right) =false)) and
  780. ((is_constintnode(left)) and (tordconstnode(left).value < 0))
  781. )
  782. ) then
  783. begin
  784. if nodetype = equaln then
  785. CGMessage(type_w_signed_unsigned_always_false)
  786. else
  787. if nodetype = unequaln then
  788. CGMessage(type_w_signed_unsigned_always_true)
  789. else
  790. if (is_constintnode(left) and (nodetype in [ltn,lten])) or
  791. (is_constintnode(right) and (nodetype in [gtn,gten])) then
  792. CGMessage(type_w_signed_unsigned_always_true)
  793. else
  794. if (is_constintnode(right) and (nodetype in [ltn,lten])) or
  795. (is_constintnode(left) and (nodetype in [gtn,gten])) then
  796. CGMessage(type_w_signed_unsigned_always_false);
  797. end;
  798. inserttypeconv(right,sinttype);
  799. inserttypeconv(left,sinttype);
  800. end;
  801. end
  802. { if both are floatdefs, conversion is already done before constant folding }
  803. else if (ld.deftype=floatdef) then
  804. begin
  805. { already converted }
  806. end
  807. { left side a setdef, must be before string processing,
  808. else array constructor can be seen as array of char (PFV) }
  809. else if (ld.deftype=setdef) then
  810. begin
  811. { trying to add a set element? }
  812. if (nodetype=addn) and (rd.deftype<>setdef) then
  813. begin
  814. if (rt=setelementn) then
  815. begin
  816. if not(equal_defs(tsetdef(ld).elementtype.def,rd)) then
  817. CGMessage(type_e_set_element_are_not_comp);
  818. end
  819. else
  820. CGMessage(type_e_mismatch)
  821. end
  822. else
  823. begin
  824. if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
  825. CGMessage(type_e_set_operation_unknown);
  826. { right def must be a also be set }
  827. if (rd.deftype<>setdef) or not(equal_defs(rd,ld)) then
  828. CGMessage(type_e_set_element_are_not_comp);
  829. end;
  830. { ranges require normsets }
  831. if (tsetdef(ld).settype=smallset) and
  832. (rt=setelementn) and
  833. assigned(tsetelementnode(right).right) then
  834. begin
  835. { generate a temporary normset def, it'll be destroyed
  836. when the symtable is unloaded }
  837. htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
  838. inserttypeconv(left,htype);
  839. end;
  840. { if the right side is also a setdef then the settype must
  841. be the same as the left setdef }
  842. if (rd.deftype=setdef) and
  843. (tsetdef(ld).settype<>tsetdef(rd).settype) then
  844. begin
  845. { when right is a normset we need to typecast both
  846. to normsets }
  847. if (tsetdef(rd).settype=normset) then
  848. inserttypeconv(left,right.resulttype)
  849. else
  850. inserttypeconv(right,left.resulttype);
  851. end;
  852. end
  853. { compare pchar to char arrays by addresses like BP/Delphi }
  854. else if ((is_pchar(ld) or (lt=niln)) and is_chararray(rd)) or
  855. ((is_pchar(rd) or (rt=niln)) and is_chararray(ld)) then
  856. begin
  857. if is_chararray(rd) then
  858. inserttypeconv(right,charpointertype)
  859. else
  860. inserttypeconv(left,charpointertype);
  861. end
  862. { pointer comparision and subtraction }
  863. else if (rd.deftype=pointerdef) and (ld.deftype=pointerdef) then
  864. begin
  865. case nodetype of
  866. equaln,unequaln :
  867. begin
  868. if is_voidpointer(right.resulttype.def) then
  869. inserttypeconv(right,left.resulttype)
  870. else if is_voidpointer(left.resulttype.def) then
  871. inserttypeconv(left,right.resulttype)
  872. else if not(equal_defs(ld,rd)) then
  873. IncompatibleTypes(ld,rd);
  874. end;
  875. ltn,lten,gtn,gten:
  876. begin
  877. if (cs_extsyntax in aktmoduleswitches) then
  878. begin
  879. if is_voidpointer(right.resulttype.def) then
  880. inserttypeconv(right,left.resulttype)
  881. else if is_voidpointer(left.resulttype.def) then
  882. inserttypeconv(left,right.resulttype)
  883. else if not(equal_defs(ld,rd)) then
  884. IncompatibleTypes(ld,rd);
  885. end
  886. else
  887. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  888. end;
  889. subn:
  890. begin
  891. if (cs_extsyntax in aktmoduleswitches) then
  892. begin
  893. if is_voidpointer(right.resulttype.def) then
  894. inserttypeconv(right,left.resulttype)
  895. else if is_voidpointer(left.resulttype.def) then
  896. inserttypeconv(left,right.resulttype)
  897. else if not(equal_defs(ld,rd)) then
  898. IncompatibleTypes(ld,rd);
  899. end
  900. else
  901. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  902. if not(nf_has_pointerdiv in flags) and
  903. (tpointerdef(rd).pointertype.def.size>1) then
  904. begin
  905. hp:=getcopy;
  906. include(hp.flags,nf_has_pointerdiv);
  907. result:=cmoddivnode.create(divn,hp,cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,false));
  908. end;
  909. resulttype:=sinttype;
  910. exit;
  911. end;
  912. addn:
  913. begin
  914. if (cs_extsyntax in aktmoduleswitches) then
  915. begin
  916. if is_voidpointer(right.resulttype.def) then
  917. inserttypeconv(right,left.resulttype)
  918. else if is_voidpointer(left.resulttype.def) then
  919. inserttypeconv(left,right.resulttype)
  920. else if not(equal_defs(ld,rd)) then
  921. IncompatibleTypes(ld,rd);
  922. end
  923. else
  924. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  925. resulttype:=sinttype;
  926. exit;
  927. end;
  928. else
  929. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  930. end;
  931. end
  932. { is one of the operands a string?,
  933. chararrays are also handled as strings (after conversion), also take
  934. care of chararray+chararray and chararray+char.
  935. Note: Must be done after pointerdef+pointerdef has been checked, else
  936. pchar is converted to string }
  937. else if (rd.deftype=stringdef) or (ld.deftype=stringdef) or
  938. ((is_pchar(rd) or is_chararray(rd) or is_char(rd)) and
  939. (is_pchar(ld) or is_chararray(ld) or is_char(ld))) then
  940. begin
  941. if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
  942. begin
  943. if is_widestring(rd) or is_widestring(ld) then
  944. begin
  945. if not(is_widestring(rd)) then
  946. inserttypeconv(right,cwidestringtype);
  947. if not(is_widestring(ld)) then
  948. inserttypeconv(left,cwidestringtype);
  949. end
  950. else if is_ansistring(rd) or is_ansistring(ld) then
  951. begin
  952. if not(is_ansistring(rd)) then
  953. begin
  954. {$ifdef ansistring_bits}
  955. case Tstringdef(ld).string_typ of
  956. st_ansistring16:
  957. inserttypeconv(right,cansistringtype16);
  958. st_ansistring32:
  959. inserttypeconv(right,cansistringtype32);
  960. st_ansistring64:
  961. inserttypeconv(right,cansistringtype64);
  962. end;
  963. {$else}
  964. inserttypeconv(right,cansistringtype);
  965. {$endif}
  966. end;
  967. if not(is_ansistring(ld)) then
  968. begin
  969. {$ifdef ansistring_bits}
  970. case Tstringdef(rd).string_typ of
  971. st_ansistring16:
  972. inserttypeconv(left,cansistringtype16);
  973. st_ansistring32:
  974. inserttypeconv(left,cansistringtype32);
  975. st_ansistring64:
  976. inserttypeconv(left,cansistringtype64);
  977. end;
  978. {$else}
  979. inserttypeconv(left,cansistringtype);
  980. {$endif}
  981. end;
  982. end
  983. else if is_longstring(rd) or is_longstring(ld) then
  984. begin
  985. if not(is_longstring(rd)) then
  986. inserttypeconv(right,clongstringtype);
  987. if not(is_longstring(ld)) then
  988. inserttypeconv(left,clongstringtype);
  989. end
  990. else
  991. begin
  992. if not(is_shortstring(ld)) then
  993. inserttypeconv(left,cshortstringtype);
  994. { don't convert char, that can be handled by the optimized node }
  995. if not(is_shortstring(rd) or is_char(rd)) then
  996. inserttypeconv(right,cshortstringtype);
  997. end;
  998. end
  999. else
  1000. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1001. end
  1002. { class or interface equation }
  1003. else if is_class_or_interface(rd) or is_class_or_interface(ld) then
  1004. begin
  1005. if (nodetype in [equaln,unequaln]) then
  1006. begin
  1007. if is_class_or_interface(rd) and is_class_or_interface(ld) then
  1008. begin
  1009. if tobjectdef(rd).is_related(tobjectdef(ld)) then
  1010. inserttypeconv(right,left.resulttype)
  1011. else
  1012. inserttypeconv(left,right.resulttype);
  1013. end
  1014. else if is_class_or_interface(rd) then
  1015. inserttypeconv(left,right.resulttype)
  1016. else
  1017. inserttypeconv(right,left.resulttype);
  1018. end
  1019. else
  1020. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1021. end
  1022. else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
  1023. begin
  1024. if (nodetype in [equaln,unequaln]) then
  1025. begin
  1026. if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
  1027. tobjectdef(tclassrefdef(ld).pointertype.def)) then
  1028. inserttypeconv(right,left.resulttype)
  1029. else
  1030. inserttypeconv(left,right.resulttype);
  1031. end
  1032. else
  1033. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1034. end
  1035. { allows comperasion with nil pointer }
  1036. else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
  1037. begin
  1038. if (nodetype in [equaln,unequaln]) then
  1039. inserttypeconv(left,right.resulttype)
  1040. else
  1041. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1042. end
  1043. else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
  1044. begin
  1045. if (nodetype in [equaln,unequaln]) then
  1046. inserttypeconv(right,left.resulttype)
  1047. else
  1048. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1049. end
  1050. { support procvar=nil,procvar<>nil }
  1051. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1052. ((rd.deftype=procvardef) and (lt=niln)) then
  1053. begin
  1054. if not(nodetype in [equaln,unequaln]) then
  1055. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1056. end
  1057. { support dynamicarray=nil,dynamicarray<>nil }
  1058. else if (is_dynamic_array(ld) and (rt=niln)) or
  1059. (is_dynamic_array(rd) and (lt=niln)) or
  1060. (is_dynamic_array(ld) and is_dynamic_array(rd)) then
  1061. begin
  1062. if not(nodetype in [equaln,unequaln]) then
  1063. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1064. end
  1065. {$ifdef SUPPORT_MMX}
  1066. { mmx support, this must be before the zero based array
  1067. check }
  1068. else if (cs_mmx in aktlocalswitches) and
  1069. is_mmx_able_array(ld) and
  1070. is_mmx_able_array(rd) and
  1071. equal_defs(ld,rd) then
  1072. begin
  1073. case nodetype of
  1074. addn,subn,xorn,orn,andn:
  1075. ;
  1076. { mul is a little bit restricted }
  1077. muln:
  1078. if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
  1079. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1080. else
  1081. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1082. end;
  1083. end
  1084. {$endif SUPPORT_MMX}
  1085. { this is a little bit dangerous, also the left type }
  1086. { pointer to should be checked! This broke the mmx support }
  1087. else if (rd.deftype=pointerdef) or is_zero_based_array(rd) then
  1088. begin
  1089. if is_zero_based_array(rd) then
  1090. begin
  1091. resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
  1092. inserttypeconv(right,resulttype);
  1093. end;
  1094. inserttypeconv(left,sinttype);
  1095. if nodetype=addn then
  1096. begin
  1097. if not(cs_extsyntax in aktmoduleswitches) or
  1098. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1099. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1100. if (rd.deftype=pointerdef) and
  1101. (tpointerdef(rd).pointertype.def.size>1) then
  1102. left:=caddnode.create(muln,left,
  1103. cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,true));
  1104. end
  1105. else
  1106. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1107. end
  1108. else if (ld.deftype=pointerdef) or is_zero_based_array(ld) then
  1109. begin
  1110. if is_zero_based_array(ld) then
  1111. begin
  1112. resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
  1113. inserttypeconv(left,resulttype);
  1114. end;
  1115. inserttypeconv(right,sinttype);
  1116. if nodetype in [addn,subn] then
  1117. begin
  1118. if not(cs_extsyntax in aktmoduleswitches) or
  1119. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1120. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1121. if (ld.deftype=pointerdef) and
  1122. (tpointerdef(ld).pointertype.def.size>1) then
  1123. right:=caddnode.create(muln,right,
  1124. cordconstnode.create(tpointerdef(ld).pointertype.def.size,sinttype,true));
  1125. end
  1126. else
  1127. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1128. end
  1129. else if (rd.deftype=procvardef) and
  1130. (ld.deftype=procvardef) and
  1131. equal_defs(rd,ld) then
  1132. begin
  1133. if (nodetype in [equaln,unequaln]) then
  1134. begin
  1135. { convert both to voidpointer, because methodpointers are 8 bytes }
  1136. { even though only the first 4 bytes must be compared (JM) }
  1137. inserttypeconv_explicit(left,voidpointertype);
  1138. inserttypeconv_explicit(right,voidpointertype);
  1139. end
  1140. else
  1141. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1142. end
  1143. { enums }
  1144. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  1145. begin
  1146. if (nodetype in [equaln,unequaln,ltn,lten,gtn,gten]) then
  1147. inserttypeconv(right,left.resulttype)
  1148. else
  1149. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1150. end
  1151. { generic conversion, this is for error recovery }
  1152. else
  1153. begin
  1154. inserttypeconv(left,sinttype);
  1155. inserttypeconv(right,sinttype);
  1156. end;
  1157. { set resulttype if not already done }
  1158. if not assigned(resulttype.def) then
  1159. begin
  1160. case nodetype of
  1161. ltn,lten,gtn,gten,equaln,unequaln :
  1162. resulttype:=booltype;
  1163. slashn :
  1164. resulttype:=resultrealtype;
  1165. addn:
  1166. begin
  1167. { for strings, return is always a 255 char string }
  1168. if is_shortstring(left.resulttype.def) then
  1169. resulttype:=cshortstringtype
  1170. else
  1171. resulttype:=left.resulttype;
  1172. end;
  1173. else
  1174. resulttype:=left.resulttype;
  1175. end;
  1176. end;
  1177. { when the result is currency we need some extra code for
  1178. multiplication and division. this should not be done when
  1179. the muln or slashn node is created internally }
  1180. if not(nf_is_currency in flags) and
  1181. is_currency(resulttype.def) then
  1182. begin
  1183. case nodetype of
  1184. slashn :
  1185. begin
  1186. { slashn will only work with floats }
  1187. hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,s64currencytype));
  1188. include(hp.flags,nf_is_currency);
  1189. result:=hp;
  1190. end;
  1191. muln :
  1192. begin
  1193. if s64currencytype.def.deftype=floatdef then
  1194. hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype))
  1195. else
  1196. hp:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,s64currencytype,false));
  1197. include(hp.flags,nf_is_currency);
  1198. result:=hp
  1199. end;
  1200. end;
  1201. end;
  1202. end;
  1203. function taddnode.first_addstring: tnode;
  1204. var
  1205. p: tnode;
  1206. begin
  1207. { when we get here, we are sure that both the left and the right }
  1208. { node are both strings of the same stringtype (JM) }
  1209. case nodetype of
  1210. addn:
  1211. begin
  1212. { create the call to the concat routine both strings as arguments }
  1213. result := ccallnode.createintern('fpc_'+
  1214. tstringdef(resulttype.def).stringtypname+'_concat',
  1215. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1216. { we reused the arguments }
  1217. left := nil;
  1218. right := nil;
  1219. end;
  1220. ltn,lten,gtn,gten,equaln,unequaln :
  1221. begin
  1222. { generate better code for s='' and s<>'' }
  1223. if (nodetype in [equaln,unequaln]) and
  1224. (((left.nodetype=stringconstn) and (str_length(left)=0)) or
  1225. ((right.nodetype=stringconstn) and (str_length(right)=0))) then
  1226. begin
  1227. { switch so that the constant is always on the right }
  1228. if left.nodetype = stringconstn then
  1229. begin
  1230. p := left;
  1231. left := right;
  1232. right := p;
  1233. end;
  1234. if is_shortstring(left.resulttype.def) then
  1235. { compare the length with 0 }
  1236. result := caddnode.create(nodetype,
  1237. cinlinenode.create(in_length_x,false,left),
  1238. cordconstnode.create(0,s32inttype,false))
  1239. else
  1240. begin
  1241. { compare the pointer with nil (for ansistrings etc), }
  1242. { faster than getting the length (JM) }
  1243. result:= caddnode.create(nodetype,
  1244. ctypeconvnode.create_explicit(left,voidpointertype),
  1245. cpointerconstnode.create(0,voidpointertype));
  1246. end;
  1247. { left is reused }
  1248. left := nil;
  1249. { right isn't }
  1250. right.free;
  1251. right := nil;
  1252. exit;
  1253. end;
  1254. { no string constant -> call compare routine }
  1255. result := ccallnode.createintern('fpc_'+
  1256. tstringdef(left.resulttype.def).stringtypname+'_compare',
  1257. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1258. { and compare its result with 0 according to the original operator }
  1259. result := caddnode.create(nodetype,result,
  1260. cordconstnode.create(0,s32inttype,false));
  1261. left := nil;
  1262. right := nil;
  1263. end;
  1264. end;
  1265. end;
  1266. function taddnode.first_addset: tnode;
  1267. var
  1268. procname: string[31];
  1269. tempn: tnode;
  1270. paras: tcallparanode;
  1271. srsym: ttypesym;
  1272. begin
  1273. { get the sym that represents the fpc_normal_set type }
  1274. if not searchsystype('FPC_NORMAL_SET',srsym) then
  1275. internalerror(200108313);
  1276. case nodetype of
  1277. equaln,unequaln,lten,gten:
  1278. begin
  1279. case nodetype of
  1280. equaln,unequaln:
  1281. procname := 'fpc_set_comp_sets';
  1282. lten,gten:
  1283. begin
  1284. procname := 'fpc_set_contains_sets';
  1285. { (left >= right) = (right <= left) }
  1286. if nodetype = gten then
  1287. begin
  1288. tempn := left;
  1289. left := right;
  1290. right := tempn;
  1291. end;
  1292. end;
  1293. end;
  1294. { convert the arguments (explicitely) to fpc_normal_set's }
  1295. left := ctypeconvnode.create_explicit(left,srsym.restype);
  1296. right := ctypeconvnode.create_explicit(right,srsym.restype);
  1297. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1298. ccallparanode.create(left,nil)));
  1299. { left and right are reused as parameters }
  1300. left := nil;
  1301. right := nil;
  1302. { for an unequaln, we have to negate the result of comp_sets }
  1303. if nodetype = unequaln then
  1304. result := cnotnode.create(result);
  1305. end;
  1306. addn:
  1307. begin
  1308. { optimize first loading of a set }
  1309. if (right.nodetype=setelementn) and
  1310. not(assigned(tsetelementnode(right).right)) and
  1311. is_emptyset(left) then
  1312. begin
  1313. { type cast the value to pass as argument to a byte, }
  1314. { since that's what the helper expects }
  1315. tsetelementnode(right).left :=
  1316. ctypeconvnode.create_explicit(tsetelementnode(right).left,u8inttype);
  1317. { set the resulttype to the actual one (otherwise it's }
  1318. { "fpc_normal_set") }
  1319. result := ccallnode.createinternres('fpc_set_create_element',
  1320. ccallparanode.create(tsetelementnode(right).left,nil),
  1321. resulttype);
  1322. { reused }
  1323. tsetelementnode(right).left := nil;
  1324. end
  1325. else
  1326. begin
  1327. if right.nodetype=setelementn then
  1328. begin
  1329. { convert the arguments to bytes, since that's what }
  1330. { the helper expects }
  1331. tsetelementnode(right).left :=
  1332. ctypeconvnode.create_explicit(tsetelementnode(right).left,
  1333. u8inttype);
  1334. { convert the original set (explicitely) to an }
  1335. { fpc_normal_set so we can pass it to the helper }
  1336. left := ctypeconvnode.create_explicit(left,srsym.restype);
  1337. { add a range or a single element? }
  1338. if assigned(tsetelementnode(right).right) then
  1339. begin
  1340. tsetelementnode(right).right :=
  1341. ctypeconvnode.create_explicit(tsetelementnode(right).right,
  1342. u8inttype);
  1343. { create the call }
  1344. result := ccallnode.createinternres('fpc_set_set_range',
  1345. ccallparanode.create(tsetelementnode(right).right,
  1346. ccallparanode.create(tsetelementnode(right).left,
  1347. ccallparanode.create(left,nil))),resulttype);
  1348. end
  1349. else
  1350. begin
  1351. result := ccallnode.createinternres('fpc_set_set_byte',
  1352. ccallparanode.create(tsetelementnode(right).left,
  1353. ccallparanode.create(left,nil)),resulttype);
  1354. end;
  1355. { remove reused parts from original node }
  1356. tsetelementnode(right).right := nil;
  1357. tsetelementnode(right).left := nil;
  1358. left := nil;
  1359. end
  1360. else
  1361. begin
  1362. { add two sets }
  1363. { convert the sets to fpc_normal_set's }
  1364. result := ccallnode.createinternres('fpc_set_add_sets',
  1365. ccallparanode.create(
  1366. ctypeconvnode.create_explicit(right,srsym.restype),
  1367. ccallparanode.create(
  1368. ctypeconvnode.create_explicit(left,srsym.restype),nil)),resulttype);
  1369. { remove reused parts from original node }
  1370. left := nil;
  1371. right := nil;
  1372. end;
  1373. end
  1374. end;
  1375. subn,symdifn,muln:
  1376. begin
  1377. { convert the sets to fpc_normal_set's }
  1378. paras := ccallparanode.create(ctypeconvnode.create_explicit(right,srsym.restype),
  1379. ccallparanode.create(ctypeconvnode.create_explicit(left,srsym.restype),nil));
  1380. case nodetype of
  1381. subn:
  1382. result := ccallnode.createinternres('fpc_set_sub_sets',
  1383. paras,resulttype);
  1384. symdifn:
  1385. result := ccallnode.createinternres('fpc_set_symdif_sets',
  1386. paras,resulttype);
  1387. muln:
  1388. result := ccallnode.createinternres('fpc_set_mul_sets',
  1389. paras,resulttype);
  1390. end;
  1391. { remove reused parts from original node }
  1392. left := nil;
  1393. right := nil;
  1394. end;
  1395. else
  1396. internalerror(200108311);
  1397. end;
  1398. end;
  1399. function taddnode.first_add64bitint: tnode;
  1400. var
  1401. procname: string[31];
  1402. temp: tnode;
  1403. power: longint;
  1404. begin
  1405. result := nil;
  1406. { create helper calls mul }
  1407. if nodetype <> muln then
  1408. exit;
  1409. { make sure that if there is a constant, that it's on the right }
  1410. if left.nodetype = ordconstn then
  1411. begin
  1412. temp := right;
  1413. right := left;
  1414. left := temp;
  1415. end;
  1416. { can we use a shift instead of a mul? }
  1417. if not (cs_check_overflow in aktlocalswitches) and
  1418. (right.nodetype = ordconstn) and
  1419. ispowerof2(tordconstnode(right).value,power) then
  1420. begin
  1421. tordconstnode(right).value := power;
  1422. result := cshlshrnode.create(shln,left,right);
  1423. { left and right are reused }
  1424. left := nil;
  1425. right := nil;
  1426. { return firstpassed new node }
  1427. exit;
  1428. end;
  1429. { when currency is used set the result of the
  1430. parameters to s64bit, so they are not converted }
  1431. if is_currency(resulttype.def) then
  1432. begin
  1433. left.resulttype:=s64inttype;
  1434. right.resulttype:=s64inttype;
  1435. end;
  1436. { otherwise, create the parameters for the helper }
  1437. right := ccallparanode.create(
  1438. cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype,true),
  1439. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1440. left := nil;
  1441. { only qword needs the unsigned code, the
  1442. signed code is also used for currency }
  1443. if is_signed(resulttype.def) then
  1444. procname := 'fpc_mul_int64'
  1445. else
  1446. procname := 'fpc_mul_qword';
  1447. result := ccallnode.createintern(procname,right);
  1448. right := nil;
  1449. end;
  1450. {$ifdef cpufpemu}
  1451. function taddnode.first_addfloat: tnode;
  1452. var
  1453. procname: string[31];
  1454. temp: tnode;
  1455. power: longint;
  1456. { do we need to reverse the result ? }
  1457. notnode : boolean;
  1458. begin
  1459. result := nil;
  1460. notnode := false;
  1461. { In non-emulation mode, real opcodes are
  1462. emitted for floating point values.
  1463. }
  1464. if not (cs_fp_emulation in aktmoduleswitches) then
  1465. exit;
  1466. case nodetype of
  1467. addn : procname := 'fpc_single_add';
  1468. muln : procname := 'fpc_single_mul';
  1469. subn : procname := 'fpc_single_sub';
  1470. slashn : procname := 'fpc_single_div';
  1471. ltn : procname := 'fpc_single_lt';
  1472. lten: procname := 'fpc_single_le';
  1473. gtn:
  1474. begin
  1475. procname := 'fpc_single_le';
  1476. notnode := true;
  1477. end;
  1478. gten:
  1479. begin
  1480. procname := 'fpc_single_lt';
  1481. notnode := true;
  1482. end;
  1483. equaln: procname := 'fpc_single_eq';
  1484. unequaln :
  1485. begin
  1486. procname := 'fpc_single_eq';
  1487. notnode := true;
  1488. end;
  1489. else
  1490. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
  1491. end;
  1492. { convert the arguments (explicitely) to fpc_normal_set's }
  1493. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1494. ccallparanode.create(left,nil)));
  1495. left:=nil;
  1496. right:=nil;
  1497. { do we need to reverse the result }
  1498. if notnode then
  1499. result := cnotnode.create(result);
  1500. end;
  1501. {$endif cpufpemu}
  1502. function taddnode.pass_1 : tnode;
  1503. var
  1504. {$ifdef addstringopt}
  1505. hp : tnode;
  1506. {$endif addstringopt}
  1507. lt,rt : tnodetype;
  1508. rd,ld : tdef;
  1509. begin
  1510. result:=nil;
  1511. { first do the two subtrees }
  1512. firstpass(left);
  1513. firstpass(right);
  1514. if codegenerror then
  1515. exit;
  1516. { load easier access variables }
  1517. rd:=right.resulttype.def;
  1518. ld:=left.resulttype.def;
  1519. rt:=right.nodetype;
  1520. lt:=left.nodetype;
  1521. { int/int gives real/real! }
  1522. if nodetype=slashn then
  1523. begin
  1524. {$ifdef cpufpemu}
  1525. result := first_addfloat;
  1526. if assigned(result) then
  1527. exit;
  1528. {$endif cpufpemu}
  1529. expectloc:=LOC_FPUREGISTER;
  1530. { maybe we need an integer register to save }
  1531. { a reference }
  1532. if ((left.expectloc<>LOC_FPUREGISTER) or
  1533. (right.expectloc<>LOC_FPUREGISTER)) and
  1534. (left.registersint=right.registersint) then
  1535. calcregisters(self,1,1,0)
  1536. else
  1537. calcregisters(self,0,1,0);
  1538. { an add node always first loads both the left and the }
  1539. { right in the fpu before doing the calculation. However, }
  1540. { calcregisters(0,2,0) will overestimate the number of }
  1541. { necessary registers (it will make it 3 in case one of }
  1542. { the operands is already in the fpu) (JM) }
  1543. if ((left.expectloc<>LOC_FPUREGISTER) or
  1544. (right.expectloc<>LOC_FPUREGISTER)) and
  1545. (registersfpu < 2) then
  1546. inc(registersfpu);
  1547. end
  1548. { if both are orddefs then check sub types }
  1549. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  1550. begin
  1551. { 2 booleans ? }
  1552. if is_boolean(ld) and is_boolean(rd) then
  1553. begin
  1554. if not(cs_full_boolean_eval in aktlocalswitches) and
  1555. (nodetype in [andn,orn]) then
  1556. begin
  1557. expectloc:=LOC_JUMP;
  1558. calcregisters(self,0,0,0);
  1559. end
  1560. else
  1561. begin
  1562. expectloc:=LOC_FLAGS;
  1563. if (left.expectloc in [LOC_JUMP,LOC_FLAGS]) and
  1564. (left.expectloc in [LOC_JUMP,LOC_FLAGS]) then
  1565. calcregisters(self,2,0,0)
  1566. else
  1567. calcregisters(self,1,0,0);
  1568. end;
  1569. end
  1570. else
  1571. { Both are chars? only convert to shortstrings for addn }
  1572. if is_char(ld) then
  1573. begin
  1574. if nodetype=addn then
  1575. internalerror(200103291);
  1576. expectloc:=LOC_FLAGS;
  1577. calcregisters(self,1,0,0);
  1578. end
  1579. {$ifndef cpu64bit}
  1580. { is there a 64 bit type ? }
  1581. else if (torddef(ld).typ in [s64bit,u64bit,scurrency]) then
  1582. begin
  1583. result := first_add64bitint;
  1584. if assigned(result) then
  1585. exit;
  1586. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1587. expectloc:=LOC_REGISTER
  1588. else
  1589. expectloc:=LOC_JUMP;
  1590. calcregisters(self,2,0,0)
  1591. end
  1592. {$endif cpu64bit}
  1593. { is there a cardinal? }
  1594. else if (torddef(ld).typ=u32bit) then
  1595. begin
  1596. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1597. expectloc:=LOC_REGISTER
  1598. else
  1599. expectloc:=LOC_FLAGS;
  1600. calcregisters(self,1,0,0);
  1601. { for unsigned mul we need an extra register }
  1602. if nodetype=muln then
  1603. inc(registersint);
  1604. end
  1605. { generic s32bit conversion }
  1606. else
  1607. begin
  1608. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1609. expectloc:=LOC_REGISTER
  1610. else
  1611. expectloc:=LOC_FLAGS;
  1612. calcregisters(self,1,0,0);
  1613. end;
  1614. end
  1615. { left side a setdef, must be before string processing,
  1616. else array constructor can be seen as array of char (PFV) }
  1617. else if (ld.deftype=setdef) then
  1618. begin
  1619. if tsetdef(ld).settype=smallset then
  1620. begin
  1621. if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
  1622. expectloc:=LOC_FLAGS
  1623. else
  1624. expectloc:=LOC_REGISTER;
  1625. { are we adding set elements ? }
  1626. if right.nodetype=setelementn then
  1627. calcregisters(self,2,0,0)
  1628. else
  1629. calcregisters(self,1,0,0);
  1630. end
  1631. else
  1632. {$ifdef MMXSET}
  1633. {$ifdef i386}
  1634. if cs_mmx in aktlocalswitches then
  1635. begin
  1636. expectloc:=LOC_MMXREGISTER;
  1637. calcregisters(self,0,0,4);
  1638. end
  1639. else
  1640. {$endif}
  1641. {$endif MMXSET}
  1642. begin
  1643. result := first_addset;
  1644. if assigned(result) then
  1645. exit;
  1646. expectloc:=LOC_CREFERENCE;
  1647. calcregisters(self,0,0,0);
  1648. { here we call SET... }
  1649. include(current_procinfo.flags,pi_do_call);
  1650. end;
  1651. end
  1652. { compare pchar by addresses like BP/Delphi }
  1653. else if is_pchar(ld) then
  1654. begin
  1655. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1656. expectloc:=LOC_REGISTER
  1657. else
  1658. expectloc:=LOC_FLAGS;
  1659. calcregisters(self,1,0,0);
  1660. end
  1661. { is one of the operands a string }
  1662. else if (ld.deftype=stringdef) then
  1663. begin
  1664. if is_widestring(ld) then
  1665. begin
  1666. { this is only for add, the comparisaion is handled later }
  1667. expectloc:=LOC_REGISTER;
  1668. end
  1669. else if is_ansistring(ld) then
  1670. begin
  1671. { this is only for add, the comparisaion is handled later }
  1672. expectloc:=LOC_REGISTER;
  1673. end
  1674. else if is_longstring(ld) then
  1675. begin
  1676. { this is only for add, the comparisaion is handled later }
  1677. expectloc:=LOC_REFERENCE;
  1678. end
  1679. else
  1680. begin
  1681. {$ifdef addstringopt}
  1682. { can create a call which isn't handled by callparatemp }
  1683. if canbeaddsstringcharoptnode(self) then
  1684. begin
  1685. hp := genaddsstringcharoptnode(self);
  1686. pass_1 := hp;
  1687. exit;
  1688. end
  1689. else
  1690. {$endif addstringopt}
  1691. begin
  1692. { Fix right to be shortstring }
  1693. if is_char(right.resulttype.def) then
  1694. begin
  1695. inserttypeconv(right,cshortstringtype);
  1696. firstpass(right);
  1697. end;
  1698. end;
  1699. {$ifdef addstringopt}
  1700. { can create a call which isn't handled by callparatemp }
  1701. if canbeaddsstringcsstringoptnode(self) then
  1702. begin
  1703. hp := genaddsstringcsstringoptnode(self);
  1704. pass_1 := hp;
  1705. exit;
  1706. end;
  1707. {$endif addstringopt}
  1708. end;
  1709. { otherwise, let addstring convert everything }
  1710. result := first_addstring;
  1711. exit;
  1712. end
  1713. { is one a real float ? }
  1714. else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
  1715. begin
  1716. {$ifdef cpufpemu}
  1717. result := first_addfloat;
  1718. if assigned(result) then
  1719. exit;
  1720. {$endif cpufpemu}
  1721. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1722. expectloc:=LOC_FPUREGISTER
  1723. else
  1724. expectloc:=LOC_FLAGS;
  1725. calcregisters(self,0,1,0);
  1726. { an add node always first loads both the left and the }
  1727. { right in the fpu before doing the calculation. However, }
  1728. { calcregisters(0,2,0) will overestimate the number of }
  1729. { necessary registers (it will make it 3 in case one of }
  1730. { the operands is already in the fpu) (JM) }
  1731. if ((left.expectloc<>LOC_FPUREGISTER) or
  1732. (right.expectloc<>LOC_FPUREGISTER)) and
  1733. (registersfpu < 2) then
  1734. inc(registersfpu);
  1735. end
  1736. { pointer comperation and subtraction }
  1737. else if (ld.deftype=pointerdef) then
  1738. begin
  1739. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1740. expectloc:=LOC_REGISTER
  1741. else
  1742. expectloc:=LOC_FLAGS;
  1743. calcregisters(self,1,0,0);
  1744. end
  1745. else if is_class_or_interface(ld) then
  1746. begin
  1747. expectloc:=LOC_FLAGS;
  1748. calcregisters(self,1,0,0);
  1749. end
  1750. else if (ld.deftype=classrefdef) then
  1751. begin
  1752. expectloc:=LOC_FLAGS;
  1753. calcregisters(self,1,0,0);
  1754. end
  1755. { support procvar=nil,procvar<>nil }
  1756. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1757. ((rd.deftype=procvardef) and (lt=niln)) then
  1758. begin
  1759. expectloc:=LOC_FLAGS;
  1760. calcregisters(self,1,0,0);
  1761. end
  1762. {$ifdef SUPPORT_MMX}
  1763. { mmx support, this must be before the zero based array
  1764. check }
  1765. else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
  1766. is_mmx_able_array(rd) then
  1767. begin
  1768. expectloc:=LOC_MMXREGISTER;
  1769. calcregisters(self,0,0,1);
  1770. end
  1771. {$endif SUPPORT_MMX}
  1772. else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
  1773. begin
  1774. expectloc:=LOC_REGISTER;
  1775. calcregisters(self,1,0,0);
  1776. end
  1777. else if (rd.deftype=procvardef) and
  1778. (ld.deftype=procvardef) and
  1779. equal_defs(rd,ld) then
  1780. begin
  1781. expectloc:=LOC_FLAGS;
  1782. calcregisters(self,1,0,0);
  1783. end
  1784. else if (ld.deftype=enumdef) then
  1785. begin
  1786. expectloc:=LOC_FLAGS;
  1787. calcregisters(self,1,0,0);
  1788. end
  1789. {$ifdef SUPPORT_MMX}
  1790. else if (cs_mmx in aktlocalswitches) and
  1791. is_mmx_able_array(ld) and
  1792. is_mmx_able_array(rd) then
  1793. begin
  1794. expectloc:=LOC_MMXREGISTER;
  1795. calcregisters(self,0,0,1);
  1796. end
  1797. {$endif SUPPORT_MMX}
  1798. { the general solution is to convert to 32 bit int }
  1799. else
  1800. begin
  1801. expectloc:=LOC_REGISTER;
  1802. calcregisters(self,1,0,0);
  1803. end;
  1804. end;
  1805. {$ifdef state_tracking}
  1806. function Taddnode.track_state_pass(exec_known:boolean):boolean;
  1807. var factval:Tnode;
  1808. begin
  1809. track_state_pass:=false;
  1810. if left.track_state_pass(exec_known) then
  1811. begin
  1812. track_state_pass:=true;
  1813. left.resulttype.def:=nil;
  1814. do_resulttypepass(left);
  1815. end;
  1816. factval:=aktstate.find_fact(left);
  1817. if factval<>nil then
  1818. begin
  1819. track_state_pass:=true;
  1820. left.destroy;
  1821. left:=factval.getcopy;
  1822. end;
  1823. if right.track_state_pass(exec_known) then
  1824. begin
  1825. track_state_pass:=true;
  1826. right.resulttype.def:=nil;
  1827. do_resulttypepass(right);
  1828. end;
  1829. factval:=aktstate.find_fact(right);
  1830. if factval<>nil then
  1831. begin
  1832. track_state_pass:=true;
  1833. right.destroy;
  1834. right:=factval.getcopy;
  1835. end;
  1836. end;
  1837. {$endif}
  1838. begin
  1839. caddnode:=taddnode;
  1840. end.
  1841. {
  1842. $Log$
  1843. Revision 1.119 2004-05-20 21:54:33 florian
  1844. + <pointer> - <pointer> result is divided by the pointer element size now
  1845. this is delphi compatible as well as resulting in the expected result for p1+(p2-p1)
  1846. Revision 1.118 2004/05/19 23:29:26 peter
  1847. * don't change sign for unsigned shl/shr operations
  1848. * cleanup for u32bit
  1849. Revision 1.117 2004/04/29 19:56:37 daniel
  1850. * Prepare compiler infrastructure for multiple ansistring types
  1851. Revision 1.116 2004/04/18 07:52:43 florian
  1852. * fixed web bug 3048: comparision of dyn. arrays
  1853. Revision 1.115 2004/03/29 14:44:10 peter
  1854. * fixes to previous constant integer commit
  1855. Revision 1.114 2004/03/23 22:34:49 peter
  1856. * constants ordinals now always have a type assigned
  1857. * integer constants have the smallest type, unsigned prefered over
  1858. signed
  1859. Revision 1.113 2004/03/18 16:19:03 peter
  1860. * fixed operator overload allowing for pointer-string
  1861. * replaced some type_e_mismatch with more informational messages
  1862. Revision 1.112 2004/02/21 22:08:46 daniel
  1863. * Avoid memory allocation and string copying
  1864. Revision 1.111 2004/02/20 21:55:59 peter
  1865. * procvar cleanup
  1866. Revision 1.110 2004/02/05 01:24:08 florian
  1867. * several fixes to compile x86-64 system
  1868. Revision 1.109 2004/02/03 22:32:54 peter
  1869. * renamed xNNbittype to xNNinttype
  1870. * renamed registers32 to registersint
  1871. * replace some s32bit,u32bit with torddef([su]inttype).def.typ
  1872. Revision 1.108 2004/02/02 20:41:59 florian
  1873. + added prefetch(const mem) support
  1874. Revision 1.107 2004/01/20 12:59:36 florian
  1875. * common addnode code for x86-64 and i386
  1876. Revision 1.106 2004/01/14 17:19:04 peter
  1877. * disable addmmxset
  1878. Revision 1.105 2004/01/02 17:19:04 jonas
  1879. * if currency = int64, FPC_CURRENCY_IS_INT64 is defined
  1880. + round and trunc for currency and comp if FPC_CURRENCY_IS_INT64 is
  1881. defined
  1882. * if currency = orddef, prefer currency -> int64/qword conversion over
  1883. currency -> float conversions
  1884. * optimized currency/currency if currency = orddef
  1885. * TODO: write FPC_DIV_CURRENCY and FPC_MUL_CURRENCY routines to prevent
  1886. precision loss if currency=int64 and bestreal = double
  1887. Revision 1.104 2003/12/31 20:47:02 jonas
  1888. * properly fixed assigned() mess (by handling it separately in ncginl)
  1889. -> all assigned()-related tests in the test suite work again
  1890. Revision 1.103 2003/12/30 16:30:50 jonas
  1891. * fixed previous commit for tp and delphi modes
  1892. Revision 1.102 2003/12/29 22:33:08 jonas
  1893. * fixed methodpointer comparing in a generic way (typecast both left and
  1894. right explicitly to voidpointer), instead of relying on strange
  1895. behvaiour or n386addnode.pass_2 (if size of def = 8, only use the first
  1896. 4 bytes instead of internalerror-ing or so)
  1897. Revision 1.101 2003/12/21 11:28:41 daniel
  1898. * Some work to allow mmx instructions to be used for 32 byte sets
  1899. Revision 1.100 2003/12/09 21:17:04 jonas
  1900. + support for evaluating qword constant expressions (both arguments have
  1901. to be a qword, constants have to be explicitly typecasted to qword)
  1902. Revision 1.99 2003/10/28 15:35:18 peter
  1903. * compare longint-cardinal also makes types wider
  1904. Revision 1.98 2003/10/21 18:16:13 peter
  1905. * IncompatibleTypes() added that will include unit names when
  1906. the typenames are the same
  1907. Revision 1.97 2003/10/08 19:19:45 peter
  1908. * set_varstate cleanup
  1909. Revision 1.96 2003/10/01 20:34:48 peter
  1910. * procinfo unit contains tprocinfo
  1911. * cginfo renamed to cgbase
  1912. * moved cgmessage to verbose
  1913. * fixed ppc and sparc compiles
  1914. Revision 1.95 2003/09/06 16:47:24 florian
  1915. + support of NaN and Inf in the compiler as values of real constants
  1916. Revision 1.94 2003/09/03 15:55:00 peter
  1917. * NEWRA branch merged
  1918. Revision 1.93.2.1 2003/08/31 21:07:44 daniel
  1919. * callparatemp ripped
  1920. Revision 1.93 2003/06/05 20:05:55 peter
  1921. * removed changesettype because that will change the definition
  1922. of the setdef forever and can result in a different between
  1923. original interface and current implementation definition
  1924. Revision 1.92 2003/06/03 21:04:43 peter
  1925. * widen cardinal+signed operations
  1926. Revision 1.91 2003/05/26 21:15:18 peter
  1927. * disable string node optimizations for the moment
  1928. Revision 1.90 2003/05/26 19:38:28 peter
  1929. * generic fpc_shorstr_concat
  1930. + fpc_shortstr_append_shortstr optimization
  1931. Revision 1.89 2003/05/24 21:12:57 florian
  1932. * if something doesn't work with callparatemp, the define callparatemp
  1933. should be used because other processors with reigster calling conventions
  1934. depend on this as well
  1935. Revision 1.88 2003/05/23 22:57:38 jonas
  1936. - disable addoptnodes for powerpc, because they can generate calls in
  1937. pass_2, so -dcallparatemp can't detect them as nested calls
  1938. Revision 1.87 2003/04/27 11:21:32 peter
  1939. * aktprocdef renamed to current_procdef
  1940. * procinfo renamed to current_procinfo
  1941. * procinfo will now be stored in current_module so it can be
  1942. cleaned up properly
  1943. * gen_main_procsym changed to create_main_proc and release_main_proc
  1944. to also generate a tprocinfo structure
  1945. * fixed unit implicit initfinal
  1946. Revision 1.86 2003/04/26 09:12:55 peter
  1947. * add string returns in LOC_REFERENCE
  1948. Revision 1.85 2003/04/24 22:29:57 florian
  1949. * fixed a lot of PowerPC related stuff
  1950. Revision 1.84 2003/04/23 20:16:04 peter
  1951. + added currency support based on int64
  1952. + is_64bit for use in cg units instead of is_64bitint
  1953. * removed cgmessage from n386add, replace with internalerrors
  1954. Revision 1.83 2003/04/23 10:10:07 peter
  1955. * expectloc fixes
  1956. Revision 1.82 2003/04/22 23:50:22 peter
  1957. * firstpass uses expectloc
  1958. * checks if there are differences between the expectloc and
  1959. location.loc from secondpass in EXTDEBUG
  1960. Revision 1.81 2003/02/15 22:20:14 carl
  1961. * bugfix for generic calls to FPU emulation code
  1962. Revision 1.80 2003/02/12 22:10:07 carl
  1963. * load_frame_pointer is now generic
  1964. * change fpu emulation routine names
  1965. Revision 1.79 2003/01/02 22:19:54 peter
  1966. * support pchar-char operations converting to string first
  1967. * support chararray-nil
  1968. Revision 1.78 2002/12/11 22:41:03 peter
  1969. * stop processing assignment node when the binaryoverload generates
  1970. a codegenerror
  1971. Revision 1.77 2002/12/06 16:56:57 peter
  1972. * only compile cs_fp_emulation support when cpufpuemu is defined
  1973. * define cpufpuemu for m68k only
  1974. Revision 1.76 2002/11/30 21:32:24 carl
  1975. + Add loading of softfpu in emulation mode
  1976. + Correct routine call for softfpu
  1977. * Extended type must also be defined even with softfpu
  1978. Revision 1.75 2002/11/27 13:11:38 peter
  1979. * more currency fixes, taddcurr runs now successfull
  1980. Revision 1.74 2002/11/27 11:28:40 peter
  1981. * when both flaottypes are the same then handle the addnode using
  1982. that floattype instead of bestrealtype
  1983. Revision 1.73 2002/11/25 18:43:32 carl
  1984. - removed the invalid if <> checking (Delphi is strange on this)
  1985. + implemented abstract warning on instance creation of class with
  1986. abstract methods.
  1987. * some error message cleanups
  1988. Revision 1.72 2002/11/25 17:43:17 peter
  1989. * splitted defbase in defutil,symutil,defcmp
  1990. * merged isconvertable and is_equal into compare_defs(_ext)
  1991. * made operator search faster by walking the list only once
  1992. Revision 1.71 2002/11/23 22:50:06 carl
  1993. * some small speed optimizations
  1994. + added several new warnings/hints
  1995. Revision 1.70 2002/11/16 14:20:22 peter
  1996. * fix tbs0417
  1997. Revision 1.69 2002/11/15 01:58:50 peter
  1998. * merged changes from 1.0.7 up to 04-11
  1999. - -V option for generating bug report tracing
  2000. - more tracing for option parsing
  2001. - errors for cdecl and high()
  2002. - win32 import stabs
  2003. - win32 records<=8 are returned in eax:edx (turned off by default)
  2004. - heaptrc update
  2005. - more info for temp management in .s file with EXTDEBUG
  2006. Revision 1.68 2002/10/08 16:50:43 jonas
  2007. * fixed web bug 2136
  2008. Revision 1.67 2002/10/05 00:47:03 peter
  2009. * support dynamicarray<>nil
  2010. Revision 1.66 2002/10/04 21:19:28 jonas
  2011. * fixed web bug 2139: checking for division by zero fixed
  2012. Revision 1.65 2002/09/07 15:25:02 peter
  2013. * old logs removed and tabs fixed
  2014. Revision 1.64 2002/09/07 12:16:05 carl
  2015. * second part bug report 1996 fix, testrange in cordconstnode
  2016. only called if option is set (also make parsing a tiny faster)
  2017. Revision 1.63 2002/09/04 19:32:56 jonas
  2018. * changed some ctypeconvnode/toggleflag(nf_explizit) combo's to
  2019. ctypeconvnode.create_explicit() statements
  2020. Revision 1.62 2002/08/17 09:23:34 florian
  2021. * first part of current_procinfo rewrite
  2022. Revision 1.61 2002/08/15 15:15:55 carl
  2023. * jmpbuf size allocation for exceptions is now cpu specific (as it should)
  2024. * more generic nodes for maths
  2025. * several fixes for better m68k support
  2026. Revision 1.60 2002/08/12 15:08:39 carl
  2027. + stab register indexes for powerpc (moved from gdb to cpubase)
  2028. + tprocessor enumeration moved to cpuinfo
  2029. + linker in target_info is now a class
  2030. * many many updates for m68k (will soon start to compile)
  2031. - removed some ifdef or correct them for correct cpu
  2032. Revision 1.59 2002/08/02 07:44:30 jonas
  2033. * made assigned() handling generic
  2034. * add nodes now can also evaluate constant expressions at compile time
  2035. that contain nil nodes
  2036. Revision 1.58 2002/07/26 11:17:52 jonas
  2037. * the optimization of converting a multiplication with a power of two to
  2038. a shl is moved from n386add/secondpass to nadd/resulttypepass
  2039. Revision 1.57 2002/07/23 13:08:16 jonas
  2040. * fixed constant set evaluation of new set handling for non-commutative
  2041. operators
  2042. Revision 1.56 2002/07/23 12:34:29 daniel
  2043. * Readded old set code. To use it define 'oldset'. Activated by default
  2044. for ppc.
  2045. Revision 1.55 2002/07/22 11:48:04 daniel
  2046. * Sets are now internally sets.
  2047. Revision 1.54 2002/07/20 11:57:53 florian
  2048. * types.pas renamed to defbase.pas because D6 contains a types
  2049. unit so this would conflicts if D6 programms are compiled
  2050. + Willamette/SSE2 instructions to assembler added
  2051. Revision 1.53 2002/07/19 11:41:34 daniel
  2052. * State tracker work
  2053. * The whilen and repeatn are now completely unified into whilerepeatn. This
  2054. allows the state tracker to change while nodes automatically into
  2055. repeat nodes.
  2056. * Resulttypepass improvements to the notn. 'not not a' is optimized away and
  2057. 'not(a>b)' is optimized into 'a<=b'.
  2058. * Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
  2059. by removing the notn and later switchting the true and falselabels. The
  2060. same is done with 'repeat until not a'.
  2061. Revision 1.52 2002/07/14 18:00:43 daniel
  2062. + Added the beginning of a state tracker. This will track the values of
  2063. variables through procedures and optimize things away.
  2064. Revision 1.51 2002/05/18 13:34:08 peter
  2065. * readded missing revisions
  2066. Revision 1.50 2002/05/16 19:46:37 carl
  2067. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  2068. + try to fix temp allocation (still in ifdef)
  2069. + generic constructor calls
  2070. + start of tassembler / tmodulebase class cleanup
  2071. Revision 1.48 2002/05/13 19:54:36 peter
  2072. * removed n386ld and n386util units
  2073. * maybe_save/maybe_restore added instead of the old maybe_push
  2074. Revision 1.47 2002/05/12 16:53:06 peter
  2075. * moved entry and exitcode to ncgutil and cgobj
  2076. * foreach gets extra argument for passing local data to the
  2077. iterator function
  2078. * -CR checks also class typecasts at runtime by changing them
  2079. into as
  2080. * fixed compiler to cycle with the -CR option
  2081. * fixed stabs with elf writer, finally the global variables can
  2082. be watched
  2083. * removed a lot of routines from cga unit and replaced them by
  2084. calls to cgobj
  2085. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  2086. u32bit then the other is typecasted also to u32bit without giving
  2087. a rangecheck warning/error.
  2088. * fixed pascal calling method with reversing also the high tree in
  2089. the parast, detected by tcalcst3 test
  2090. Revision 1.46 2002/04/23 19:16:34 peter
  2091. * add pinline unit that inserts compiler supported functions using
  2092. one or more statements
  2093. * moved finalize and setlength from ninl to pinline
  2094. Revision 1.45 2002/04/04 19:05:56 peter
  2095. * removed unused units
  2096. * use tlocation.size in cg.a_*loc*() routines
  2097. Revision 1.44 2002/04/02 17:11:28 peter
  2098. * tlocation,treference update
  2099. * LOC_CONSTANT added for better constant handling
  2100. * secondadd splitted in multiple routines
  2101. * location_force_reg added for loading a location to a register
  2102. of a specified size
  2103. * secondassignment parses now first the right and then the left node
  2104. (this is compatible with Kylix). This saves a lot of push/pop especially
  2105. with string operations
  2106. * adapted some routines to use the new cg methods
  2107. }