nadd.pas 87 KB

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