nadd.pas 88 KB

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