nadd.pas 88 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240
  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 is_signed(right.resulttype.def) then
  918. begin
  919. CGMessage(type_w_mixed_signed_unsigned);
  920. inserttypeconv(left,s64inttype);
  921. inserttypeconv(right,s64inttype);
  922. end
  923. else
  924. begin
  925. { convert positive constants to u32bit }
  926. if (torddef(ld).typ<>u32bit) and
  927. is_constintnode(left) and
  928. (tordconstnode(left).value >= 0) then
  929. inserttypeconv(left,u32inttype);
  930. if (torddef(rd).typ<>u32bit) and
  931. is_constintnode(right) and
  932. (tordconstnode(right).value >= 0) then
  933. inserttypeconv(right,u32inttype);
  934. { when one of the operand is signed perform
  935. the operation in 64bit, can't use rd/ld here because there
  936. could be already typeconvs inserted }
  937. if is_signed(left.resulttype.def) or is_signed(right.resulttype.def) then
  938. begin
  939. CGMessage(type_w_mixed_signed_unsigned);
  940. inserttypeconv(left,s64inttype);
  941. inserttypeconv(right,s64inttype);
  942. end
  943. { For substraction the result can be < 0 but also > maxlongint, we
  944. fallback to int64 that can handle both }
  945. else if (nodetype=subn) then
  946. begin
  947. inserttypeconv(left,s64inttype);
  948. inserttypeconv(right,s64inttype);
  949. end
  950. else
  951. begin
  952. if (torddef(left.resulttype.def).typ<>u32bit) then
  953. inserttypeconv(left,u32inttype);
  954. if (torddef(right.resulttype.def).typ<>u32bit) then
  955. inserttypeconv(right,u32inttype);
  956. end;
  957. end;
  958. end
  959. {$endif cpu64bit}
  960. { generic ord conversion is sinttype }
  961. else
  962. begin
  963. { if the left or right value is smaller than the normal
  964. type s32inttype and is unsigned, and the other value
  965. is a constant < 0, the result will always be false/true
  966. for equal / unequal nodes.
  967. }
  968. if (
  969. { left : unsigned ordinal var, right : < 0 constant }
  970. (
  971. ((is_signed(ld)=false) and (is_constintnode(left) =false)) and
  972. ((is_constintnode(right)) and (tordconstnode(right).value < 0))
  973. ) or
  974. { right : unsigned ordinal var, left : < 0 constant }
  975. (
  976. ((is_signed(rd)=false) and (is_constintnode(right) =false)) and
  977. ((is_constintnode(left)) and (tordconstnode(left).value < 0))
  978. )
  979. ) then
  980. begin
  981. if nodetype = equaln then
  982. CGMessage(type_w_signed_unsigned_always_false)
  983. else
  984. if nodetype = unequaln then
  985. CGMessage(type_w_signed_unsigned_always_true)
  986. else
  987. if (is_constintnode(left) and (nodetype in [ltn,lten])) or
  988. (is_constintnode(right) and (nodetype in [gtn,gten])) then
  989. CGMessage(type_w_signed_unsigned_always_true)
  990. else
  991. if (is_constintnode(right) and (nodetype in [ltn,lten])) or
  992. (is_constintnode(left) and (nodetype in [gtn,gten])) then
  993. CGMessage(type_w_signed_unsigned_always_false);
  994. end;
  995. { When there is a signed type we convert to signed int.
  996. Otherwise (both are unsigned) we keep the result also unsigned }
  997. if (is_signed(ld) or is_signed(rd)) then
  998. begin
  999. inserttypeconv(right,sinttype);
  1000. inserttypeconv(left,sinttype);
  1001. end
  1002. else
  1003. begin
  1004. inserttypeconv(right,uinttype);
  1005. inserttypeconv(left,uinttype);
  1006. end;
  1007. end;
  1008. end
  1009. { if both are floatdefs, conversion is already done before constant folding }
  1010. else if (ld.deftype=floatdef) then
  1011. begin
  1012. { already converted }
  1013. end
  1014. { left side a setdef, must be before string processing,
  1015. else array constructor can be seen as array of char (PFV) }
  1016. else if (ld.deftype=setdef) then
  1017. begin
  1018. { trying to add a set element? }
  1019. if (nodetype=addn) and (rd.deftype<>setdef) then
  1020. begin
  1021. if (rt=setelementn) then
  1022. begin
  1023. if not(equal_defs(tsetdef(ld).elementtype.def,rd)) then
  1024. CGMessage(type_e_set_element_are_not_comp);
  1025. end
  1026. else
  1027. CGMessage(type_e_mismatch)
  1028. end
  1029. else
  1030. begin
  1031. if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
  1032. CGMessage(type_e_set_operation_unknown);
  1033. { right def must be a also be set }
  1034. if (rd.deftype<>setdef) or not(equal_defs(rd,ld)) then
  1035. CGMessage(type_e_set_element_are_not_comp);
  1036. end;
  1037. { ranges require normsets }
  1038. if (tsetdef(ld).settype=smallset) and
  1039. (rt=setelementn) and
  1040. assigned(tsetelementnode(right).right) then
  1041. begin
  1042. { generate a temporary normset def, it'll be destroyed
  1043. when the symtable is unloaded }
  1044. htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
  1045. inserttypeconv(left,htype);
  1046. end;
  1047. { if the right side is also a setdef then the settype must
  1048. be the same as the left setdef }
  1049. if (rd.deftype=setdef) and
  1050. (tsetdef(ld).settype<>tsetdef(rd).settype) then
  1051. begin
  1052. { when right is a normset we need to typecast both
  1053. to normsets }
  1054. if (tsetdef(rd).settype=normset) then
  1055. inserttypeconv(left,right.resulttype)
  1056. else
  1057. inserttypeconv(right,left.resulttype);
  1058. end;
  1059. end
  1060. { compare pchar to char arrays by addresses like BP/Delphi }
  1061. else if ((is_pchar(ld) or (lt=niln)) and is_chararray(rd)) or
  1062. ((is_pchar(rd) or (rt=niln)) and is_chararray(ld)) then
  1063. begin
  1064. if is_chararray(rd) then
  1065. inserttypeconv(right,charpointertype)
  1066. else
  1067. inserttypeconv(left,charpointertype);
  1068. end
  1069. { pointer comparision and subtraction }
  1070. else if (rd.deftype=pointerdef) and (ld.deftype=pointerdef) then
  1071. begin
  1072. case nodetype of
  1073. equaln,unequaln :
  1074. begin
  1075. if is_voidpointer(right.resulttype.def) then
  1076. inserttypeconv(right,left.resulttype)
  1077. else if is_voidpointer(left.resulttype.def) then
  1078. inserttypeconv(left,right.resulttype)
  1079. else if not(equal_defs(ld,rd)) then
  1080. IncompatibleTypes(ld,rd);
  1081. { now that the type checking is done, convert both to charpointer, }
  1082. { because methodpointers are 8 bytes even though only the first 4 }
  1083. { bytes must be compared. This can happen here if we are in }
  1084. { TP/Delphi mode, because there @methodpointer = voidpointer (but }
  1085. { a voidpointer of 8 bytes). A conversion to voidpointer would be }
  1086. { optimized away, since the result already was a voidpointer, so }
  1087. { use a charpointer instead (JM) }
  1088. inserttypeconv_internal(left,charpointertype);
  1089. inserttypeconv_internal(right,charpointertype);
  1090. end;
  1091. ltn,lten,gtn,gten:
  1092. begin
  1093. if (cs_extsyntax in aktmoduleswitches) then
  1094. begin
  1095. if is_voidpointer(right.resulttype.def) then
  1096. inserttypeconv(right,left.resulttype)
  1097. else if is_voidpointer(left.resulttype.def) then
  1098. inserttypeconv(left,right.resulttype)
  1099. else if not(equal_defs(ld,rd)) then
  1100. IncompatibleTypes(ld,rd);
  1101. end
  1102. else
  1103. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1104. end;
  1105. subn:
  1106. begin
  1107. if (cs_extsyntax in aktmoduleswitches) then
  1108. begin
  1109. if is_voidpointer(right.resulttype.def) then
  1110. inserttypeconv(right,left.resulttype)
  1111. else if is_voidpointer(left.resulttype.def) then
  1112. inserttypeconv(left,right.resulttype)
  1113. else if not(equal_defs(ld,rd)) then
  1114. IncompatibleTypes(ld,rd);
  1115. end
  1116. else
  1117. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1118. if not(nf_has_pointerdiv in flags) and
  1119. (tpointerdef(rd).pointertype.def.size>1) then
  1120. begin
  1121. hp:=getcopy;
  1122. include(hp.flags,nf_has_pointerdiv);
  1123. result:=cmoddivnode.create(divn,hp,cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,false));
  1124. end;
  1125. resulttype:=sinttype;
  1126. exit;
  1127. end;
  1128. addn:
  1129. begin
  1130. if (cs_extsyntax in aktmoduleswitches) then
  1131. begin
  1132. if is_voidpointer(right.resulttype.def) then
  1133. inserttypeconv(right,left.resulttype)
  1134. else if is_voidpointer(left.resulttype.def) then
  1135. inserttypeconv(left,right.resulttype)
  1136. else if not(equal_defs(ld,rd)) then
  1137. IncompatibleTypes(ld,rd);
  1138. end
  1139. else
  1140. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1141. resulttype:=sinttype;
  1142. exit;
  1143. end;
  1144. else
  1145. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1146. end;
  1147. end
  1148. { is one of the operands a string?,
  1149. chararrays are also handled as strings (after conversion), also take
  1150. care of chararray+chararray and chararray+char.
  1151. Note: Must be done after pointerdef+pointerdef has been checked, else
  1152. pchar is converted to string }
  1153. else if (rd.deftype=stringdef) or
  1154. (ld.deftype=stringdef) or
  1155. ((is_pchar(rd) or is_chararray(rd) or is_char(rd) or is_open_chararray(rd) or
  1156. is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd)) and
  1157. (is_pchar(ld) or is_chararray(ld) or is_char(ld) or is_open_chararray(ld) or
  1158. is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld))) then
  1159. begin
  1160. if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
  1161. begin
  1162. { Is there a widestring? }
  1163. if is_widestring(rd) or is_widestring(ld) or
  1164. is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd) or
  1165. is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld) then
  1166. strtype:= st_widestring
  1167. else
  1168. if is_ansistring(rd) or is_ansistring(ld) or
  1169. ((cs_ansistrings in aktlocalswitches) and
  1170. //todo: Move some of this to longstring's then they are implemented?
  1171. (
  1172. is_pchar(rd) or (is_chararray(rd) and (rd.size > 255)) or is_open_chararray(rd) or
  1173. is_pchar(ld) or (is_chararray(ld) and (ld.size > 255)) or is_open_chararray(ld)
  1174. )
  1175. ) then
  1176. strtype:= st_ansistring
  1177. else
  1178. if is_longstring(rd) or is_longstring(ld) then
  1179. strtype:= st_longstring
  1180. else
  1181. begin
  1182. {$warning todo: add a warning/hint here if one converting a too large array}
  1183. { nodes is PChar, array [with size > 255] or OpenArrayOfChar.
  1184. Note: Delphi halts with error if "array [0..xx] of char"
  1185. is assigned to ShortString and string length is less
  1186. then array size }
  1187. strtype:= st_shortstring;
  1188. end;
  1189. // Now convert nodes to common string type
  1190. case strtype of
  1191. st_widestring :
  1192. begin
  1193. if not(is_widestring(rd)) then
  1194. inserttypeconv(right,cwidestringtype);
  1195. if not(is_widestring(ld)) then
  1196. inserttypeconv(left,cwidestringtype);
  1197. end;
  1198. st_ansistring :
  1199. begin
  1200. if not(is_ansistring(rd)) then
  1201. inserttypeconv(right,cansistringtype);
  1202. if not(is_ansistring(ld)) then
  1203. inserttypeconv(left,cansistringtype);
  1204. end;
  1205. st_longstring :
  1206. begin
  1207. if not(is_longstring(rd)) then
  1208. inserttypeconv(right,clongstringtype);
  1209. if not(is_longstring(ld)) then
  1210. inserttypeconv(left,clongstringtype);
  1211. end;
  1212. st_shortstring :
  1213. begin
  1214. if not(is_shortstring(ld)) then
  1215. inserttypeconv(left,cshortstringtype);
  1216. { don't convert char, that can be handled by the optimized node }
  1217. if not(is_shortstring(rd) or is_char(rd)) then
  1218. inserttypeconv(right,cshortstringtype);
  1219. end;
  1220. else
  1221. internalerror(2005101);
  1222. end;
  1223. end
  1224. else
  1225. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1226. end
  1227. { class or interface equation }
  1228. else if is_class_or_interface(rd) or is_class_or_interface(ld) then
  1229. begin
  1230. if (nodetype in [equaln,unequaln]) then
  1231. begin
  1232. if is_class_or_interface(rd) and is_class_or_interface(ld) then
  1233. begin
  1234. if tobjectdef(rd).is_related(tobjectdef(ld)) then
  1235. inserttypeconv(right,left.resulttype)
  1236. else
  1237. inserttypeconv(left,right.resulttype);
  1238. end
  1239. else if is_class_or_interface(rd) then
  1240. inserttypeconv(left,right.resulttype)
  1241. else
  1242. inserttypeconv(right,left.resulttype);
  1243. end
  1244. else
  1245. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1246. end
  1247. else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
  1248. begin
  1249. if (nodetype in [equaln,unequaln]) then
  1250. begin
  1251. if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
  1252. tobjectdef(tclassrefdef(ld).pointertype.def)) then
  1253. inserttypeconv(right,left.resulttype)
  1254. else
  1255. inserttypeconv(left,right.resulttype);
  1256. end
  1257. else
  1258. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1259. end
  1260. { allows comperasion with nil pointer }
  1261. else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
  1262. begin
  1263. if (nodetype in [equaln,unequaln]) then
  1264. inserttypeconv(left,right.resulttype)
  1265. else
  1266. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1267. end
  1268. else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
  1269. begin
  1270. if (nodetype in [equaln,unequaln]) then
  1271. inserttypeconv(right,left.resulttype)
  1272. else
  1273. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1274. end
  1275. { support procvar=nil,procvar<>nil }
  1276. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1277. ((rd.deftype=procvardef) and (lt=niln)) then
  1278. begin
  1279. if not(nodetype in [equaln,unequaln]) then
  1280. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1281. { find proc field in methodpointer record }
  1282. hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
  1283. if not assigned(hsym) then
  1284. internalerror(200412043);
  1285. { For methodpointers compare only tmethodpointer.proc }
  1286. if (rd.deftype=procvardef) and
  1287. (not tprocvardef(rd).is_addressonly) then
  1288. begin
  1289. right:=csubscriptnode.create(
  1290. hsym,
  1291. ctypeconvnode.create_internal(right,methodpointertype));
  1292. end;
  1293. if (ld.deftype=procvardef) and
  1294. (not tprocvardef(ld).is_addressonly) then
  1295. begin
  1296. left:=csubscriptnode.create(
  1297. hsym,
  1298. ctypeconvnode.create_internal(left,methodpointertype));
  1299. end;
  1300. end
  1301. { support dynamicarray=nil,dynamicarray<>nil }
  1302. else if (is_dynamic_array(ld) and (rt=niln)) or
  1303. (is_dynamic_array(rd) and (lt=niln)) or
  1304. (is_dynamic_array(ld) and is_dynamic_array(rd)) then
  1305. begin
  1306. if not(nodetype in [equaln,unequaln]) then
  1307. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1308. end
  1309. {$ifdef SUPPORT_MMX}
  1310. { mmx support, this must be before the zero based array
  1311. check }
  1312. else if (cs_mmx in aktlocalswitches) and
  1313. is_mmx_able_array(ld) and
  1314. is_mmx_able_array(rd) and
  1315. equal_defs(ld,rd) then
  1316. begin
  1317. case nodetype of
  1318. addn,subn,xorn,orn,andn:
  1319. ;
  1320. { mul is a little bit restricted }
  1321. muln:
  1322. if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
  1323. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1324. else
  1325. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1326. end;
  1327. end
  1328. {$endif SUPPORT_MMX}
  1329. { this is a little bit dangerous, also the left type }
  1330. { pointer to should be checked! This broke the mmx support }
  1331. else if (rd.deftype=pointerdef) or is_zero_based_array(rd) then
  1332. begin
  1333. if is_zero_based_array(rd) then
  1334. begin
  1335. resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
  1336. inserttypeconv(right,resulttype);
  1337. end
  1338. else
  1339. resulttype:=right.resulttype;
  1340. inserttypeconv(left,sinttype);
  1341. if nodetype=addn then
  1342. begin
  1343. if not(cs_extsyntax in aktmoduleswitches) or
  1344. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1345. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1346. if (rd.deftype=pointerdef) and
  1347. (tpointerdef(rd).pointertype.def.size>1) then
  1348. begin
  1349. left:=caddnode.create(muln,left,
  1350. cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,true));
  1351. end;
  1352. end
  1353. else
  1354. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1355. end
  1356. else if (ld.deftype=pointerdef) or is_zero_based_array(ld) then
  1357. begin
  1358. if is_zero_based_array(ld) then
  1359. begin
  1360. resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
  1361. inserttypeconv(left,resulttype);
  1362. end
  1363. else
  1364. resulttype:=left.resulttype;
  1365. inserttypeconv(right,sinttype);
  1366. if nodetype in [addn,subn] then
  1367. begin
  1368. if not(cs_extsyntax in aktmoduleswitches) or
  1369. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1370. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1371. if (ld.deftype=pointerdef) and
  1372. (tpointerdef(ld).pointertype.def.size>1) then
  1373. begin
  1374. right:=caddnode.create(muln,right,
  1375. cordconstnode.create(tpointerdef(ld).pointertype.def.size,sinttype,true));
  1376. end
  1377. else
  1378. if is_zero_based_array(ld) and
  1379. (tarraydef(ld).elementtype.def.size>1) then
  1380. begin
  1381. right:=caddnode.create(muln,right,
  1382. cordconstnode.create(tarraydef(ld).elementtype.def.size,sinttype,true));
  1383. end;
  1384. end
  1385. else
  1386. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1387. end
  1388. else if (rd.deftype=procvardef) and
  1389. (ld.deftype=procvardef) and
  1390. equal_defs(rd,ld) then
  1391. begin
  1392. if (nodetype in [equaln,unequaln]) then
  1393. begin
  1394. if tprocvardef(rd).is_addressonly then
  1395. begin
  1396. inserttypeconv_internal(right,voidpointertype);
  1397. inserttypeconv_internal(left,voidpointertype);
  1398. end
  1399. else
  1400. begin
  1401. { find proc field in methodpointer record }
  1402. hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
  1403. if not assigned(hsym) then
  1404. internalerror(200412043);
  1405. { Compare tmehodpointer(left).proc }
  1406. right:=csubscriptnode.create(
  1407. hsym,
  1408. ctypeconvnode.create_internal(right,methodpointertype));
  1409. left:=csubscriptnode.create(
  1410. hsym,
  1411. ctypeconvnode.create_internal(left,methodpointertype));
  1412. end;
  1413. end
  1414. else
  1415. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1416. end
  1417. { enums }
  1418. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  1419. begin
  1420. if allowenumop(nodetype) then
  1421. inserttypeconv(right,left.resulttype)
  1422. else
  1423. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1424. end
  1425. { generic conversion, this is for error recovery }
  1426. else
  1427. begin
  1428. inserttypeconv(left,sinttype);
  1429. inserttypeconv(right,sinttype);
  1430. end;
  1431. { set resulttype if not already done }
  1432. if not assigned(resulttype.def) then
  1433. begin
  1434. case nodetype of
  1435. ltn,lten,gtn,gten,equaln,unequaln :
  1436. resulttype:=booltype;
  1437. slashn :
  1438. resulttype:=resultrealtype;
  1439. addn:
  1440. begin
  1441. { for strings, return is always a 255 char string }
  1442. if is_shortstring(left.resulttype.def) then
  1443. resulttype:=cshortstringtype
  1444. else
  1445. resulttype:=left.resulttype;
  1446. end;
  1447. else
  1448. resulttype:=left.resulttype;
  1449. end;
  1450. end;
  1451. { when the result is currency we need some extra code for
  1452. multiplication and division. this should not be done when
  1453. the muln or slashn node is created internally }
  1454. if not(nf_is_currency in flags) and
  1455. is_currency(resulttype.def) then
  1456. begin
  1457. case nodetype of
  1458. slashn :
  1459. begin
  1460. { slashn will only work with floats }
  1461. hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,s64currencytype));
  1462. include(hp.flags,nf_is_currency);
  1463. result:=hp;
  1464. end;
  1465. muln :
  1466. begin
  1467. if s64currencytype.def.deftype=floatdef then
  1468. hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype))
  1469. else
  1470. hp:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,s64currencytype,false));
  1471. include(hp.flags,nf_is_currency);
  1472. result:=hp
  1473. end;
  1474. end;
  1475. end;
  1476. end;
  1477. function taddnode.first_addstring: tnode;
  1478. var
  1479. p: tnode;
  1480. begin
  1481. { when we get here, we are sure that both the left and the right }
  1482. { node are both strings of the same stringtype (JM) }
  1483. case nodetype of
  1484. addn:
  1485. begin
  1486. { create the call to the concat routine both strings as arguments }
  1487. result := ccallnode.createintern('fpc_'+
  1488. tstringdef(resulttype.def).stringtypname+'_concat',
  1489. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1490. { we reused the arguments }
  1491. left := nil;
  1492. right := nil;
  1493. end;
  1494. ltn,lten,gtn,gten,equaln,unequaln :
  1495. begin
  1496. { generate better code for comparison with empty string, we
  1497. only need to compare the length with 0 }
  1498. if (nodetype in [equaln,unequaln,gtn,gten,ltn,lten]) and
  1499. (((left.nodetype=stringconstn) and (str_length(left)=0)) or
  1500. ((right.nodetype=stringconstn) and (str_length(right)=0))) then
  1501. begin
  1502. { switch so that the constant is always on the right }
  1503. if left.nodetype = stringconstn then
  1504. begin
  1505. p := left;
  1506. left := right;
  1507. right := p;
  1508. end;
  1509. if is_shortstring(left.resulttype.def) or
  1510. (nodetype in [gtn,gten,ltn,lten]) then
  1511. { compare the length with 0 }
  1512. result := caddnode.create(nodetype,
  1513. cinlinenode.create(in_length_x,false,left),
  1514. cordconstnode.create(0,s32inttype,false))
  1515. else
  1516. begin
  1517. { compare the pointer with nil (for ansistrings etc), }
  1518. { faster than getting the length (JM) }
  1519. result:= caddnode.create(nodetype,
  1520. ctypeconvnode.create_internal(left,voidpointertype),
  1521. cpointerconstnode.create(0,voidpointertype));
  1522. end;
  1523. { left is reused }
  1524. left := nil;
  1525. { right isn't }
  1526. right.free;
  1527. right := nil;
  1528. exit;
  1529. end;
  1530. { no string constant -> call compare routine }
  1531. result := ccallnode.createintern('fpc_'+
  1532. tstringdef(left.resulttype.def).stringtypname+'_compare',
  1533. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1534. { and compare its result with 0 according to the original operator }
  1535. result := caddnode.create(nodetype,result,
  1536. cordconstnode.create(0,s32inttype,false));
  1537. left := nil;
  1538. right := nil;
  1539. end;
  1540. end;
  1541. end;
  1542. function taddnode.first_addset: tnode;
  1543. var
  1544. procname: string[31];
  1545. tempn: tnode;
  1546. paras: tcallparanode;
  1547. srsym: ttypesym;
  1548. begin
  1549. { get the sym that represents the fpc_normal_set type }
  1550. if not searchsystype('FPC_NORMAL_SET',srsym) then
  1551. internalerror(200108313);
  1552. case nodetype of
  1553. equaln,unequaln,lten,gten:
  1554. begin
  1555. case nodetype of
  1556. equaln,unequaln:
  1557. procname := 'fpc_set_comp_sets';
  1558. lten,gten:
  1559. begin
  1560. procname := 'fpc_set_contains_sets';
  1561. { (left >= right) = (right <= left) }
  1562. if nodetype = gten then
  1563. begin
  1564. tempn := left;
  1565. left := right;
  1566. right := tempn;
  1567. end;
  1568. end;
  1569. end;
  1570. { convert the arguments (explicitely) to fpc_normal_set's }
  1571. left := ctypeconvnode.create_internal(left,srsym.restype);
  1572. right := ctypeconvnode.create_internal(right,srsym.restype);
  1573. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1574. ccallparanode.create(left,nil)));
  1575. { left and right are reused as parameters }
  1576. left := nil;
  1577. right := nil;
  1578. { for an unequaln, we have to negate the result of comp_sets }
  1579. if nodetype = unequaln then
  1580. result := cnotnode.create(result);
  1581. end;
  1582. addn:
  1583. begin
  1584. { optimize first loading of a set }
  1585. if (right.nodetype=setelementn) and
  1586. not(assigned(tsetelementnode(right).right)) and
  1587. is_emptyset(left) then
  1588. begin
  1589. { type cast the value to pass as argument to a byte, }
  1590. { since that's what the helper expects }
  1591. tsetelementnode(right).left :=
  1592. ctypeconvnode.create_internal(tsetelementnode(right).left,u8inttype);
  1593. { set the resulttype to the actual one (otherwise it's }
  1594. { "fpc_normal_set") }
  1595. result := ccallnode.createinternres('fpc_set_create_element',
  1596. ccallparanode.create(tsetelementnode(right).left,nil),
  1597. resulttype);
  1598. { reused }
  1599. tsetelementnode(right).left := nil;
  1600. end
  1601. else
  1602. begin
  1603. if right.nodetype=setelementn then
  1604. begin
  1605. { convert the arguments to bytes, since that's what }
  1606. { the helper expects }
  1607. tsetelementnode(right).left :=
  1608. ctypeconvnode.create_internal(tsetelementnode(right).left,
  1609. u8inttype);
  1610. { convert the original set (explicitely) to an }
  1611. { fpc_normal_set so we can pass it to the helper }
  1612. left := ctypeconvnode.create_internal(left,srsym.restype);
  1613. { add a range or a single element? }
  1614. if assigned(tsetelementnode(right).right) then
  1615. begin
  1616. tsetelementnode(right).right :=
  1617. ctypeconvnode.create_internal(tsetelementnode(right).right,
  1618. u8inttype);
  1619. { create the call }
  1620. result := ccallnode.createinternres('fpc_set_set_range',
  1621. ccallparanode.create(tsetelementnode(right).right,
  1622. ccallparanode.create(tsetelementnode(right).left,
  1623. ccallparanode.create(left,nil))),resulttype);
  1624. end
  1625. else
  1626. begin
  1627. result := ccallnode.createinternres('fpc_set_set_byte',
  1628. ccallparanode.create(tsetelementnode(right).left,
  1629. ccallparanode.create(left,nil)),resulttype);
  1630. end;
  1631. { remove reused parts from original node }
  1632. tsetelementnode(right).right := nil;
  1633. tsetelementnode(right).left := nil;
  1634. left := nil;
  1635. end
  1636. else
  1637. begin
  1638. { add two sets }
  1639. { convert the sets to fpc_normal_set's }
  1640. result := ccallnode.createinternres('fpc_set_add_sets',
  1641. ccallparanode.create(
  1642. ctypeconvnode.create_explicit(right,srsym.restype),
  1643. ccallparanode.create(
  1644. ctypeconvnode.create_internal(left,srsym.restype),nil)),resulttype);
  1645. { remove reused parts from original node }
  1646. left := nil;
  1647. right := nil;
  1648. end;
  1649. end
  1650. end;
  1651. subn,symdifn,muln:
  1652. begin
  1653. { convert the sets to fpc_normal_set's }
  1654. paras := ccallparanode.create(ctypeconvnode.create_internal(right,srsym.restype),
  1655. ccallparanode.create(ctypeconvnode.create_internal(left,srsym.restype),nil));
  1656. case nodetype of
  1657. subn:
  1658. result := ccallnode.createinternres('fpc_set_sub_sets',
  1659. paras,resulttype);
  1660. symdifn:
  1661. result := ccallnode.createinternres('fpc_set_symdif_sets',
  1662. paras,resulttype);
  1663. muln:
  1664. result := ccallnode.createinternres('fpc_set_mul_sets',
  1665. paras,resulttype);
  1666. end;
  1667. { remove reused parts from original node }
  1668. left := nil;
  1669. right := nil;
  1670. end;
  1671. else
  1672. internalerror(200108311);
  1673. end;
  1674. end;
  1675. function taddnode.first_add64bitint: tnode;
  1676. var
  1677. procname: string[31];
  1678. temp: tnode;
  1679. power: longint;
  1680. begin
  1681. result := nil;
  1682. { create helper calls mul }
  1683. if nodetype <> muln then
  1684. exit;
  1685. { make sure that if there is a constant, that it's on the right }
  1686. if left.nodetype = ordconstn then
  1687. begin
  1688. temp := right;
  1689. right := left;
  1690. left := temp;
  1691. end;
  1692. { can we use a shift instead of a mul? }
  1693. if not (cs_check_overflow in aktlocalswitches) and
  1694. (right.nodetype = ordconstn) and
  1695. ispowerof2(tordconstnode(right).value,power) then
  1696. begin
  1697. tordconstnode(right).value := power;
  1698. result := cshlshrnode.create(shln,left,right);
  1699. { left and right are reused }
  1700. left := nil;
  1701. right := nil;
  1702. { return firstpassed new node }
  1703. exit;
  1704. end;
  1705. { when currency is used set the result of the
  1706. parameters to s64bit, so they are not converted }
  1707. if is_currency(resulttype.def) then
  1708. begin
  1709. left.resulttype:=s64inttype;
  1710. right.resulttype:=s64inttype;
  1711. end;
  1712. { otherwise, create the parameters for the helper }
  1713. right := ccallparanode.create(
  1714. cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype,true),
  1715. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1716. left := nil;
  1717. { only qword needs the unsigned code, the
  1718. signed code is also used for currency }
  1719. if is_signed(resulttype.def) then
  1720. procname := 'fpc_mul_int64'
  1721. else
  1722. procname := 'fpc_mul_qword';
  1723. result := ccallnode.createintern(procname,right);
  1724. right := nil;
  1725. end;
  1726. {$ifdef cpufpemu}
  1727. function taddnode.first_addfloat: tnode;
  1728. var
  1729. procname: string[31];
  1730. temp: tnode;
  1731. power: longint;
  1732. { do we need to reverse the result ? }
  1733. notnode : boolean;
  1734. begin
  1735. result := nil;
  1736. notnode := false;
  1737. { In non-emulation mode, real opcodes are
  1738. emitted for floating point values.
  1739. }
  1740. if not (cs_fp_emulation in aktmoduleswitches) then
  1741. exit;
  1742. case nodetype of
  1743. addn : procname := 'fpc_single_add';
  1744. muln : procname := 'fpc_single_mul';
  1745. subn : procname := 'fpc_single_sub';
  1746. slashn : procname := 'fpc_single_div';
  1747. ltn : procname := 'fpc_single_lt';
  1748. lten: procname := 'fpc_single_le';
  1749. gtn:
  1750. begin
  1751. procname := 'fpc_single_le';
  1752. notnode := true;
  1753. end;
  1754. gten:
  1755. begin
  1756. procname := 'fpc_single_lt';
  1757. notnode := true;
  1758. end;
  1759. equaln: procname := 'fpc_single_eq';
  1760. unequaln :
  1761. begin
  1762. procname := 'fpc_single_eq';
  1763. notnode := true;
  1764. end;
  1765. else
  1766. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
  1767. end;
  1768. { convert the arguments (explicitely) to fpc_normal_set's }
  1769. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1770. ccallparanode.create(left,nil)));
  1771. left:=nil;
  1772. right:=nil;
  1773. { do we need to reverse the result }
  1774. if notnode then
  1775. result := cnotnode.create(result);
  1776. end;
  1777. {$endif cpufpemu}
  1778. function taddnode.pass_1 : tnode;
  1779. var
  1780. {$ifdef addstringopt}
  1781. hp : tnode;
  1782. {$endif addstringopt}
  1783. lt,rt : tnodetype;
  1784. rd,ld : tdef;
  1785. begin
  1786. result:=nil;
  1787. { first do the two subtrees }
  1788. firstpass(left);
  1789. firstpass(right);
  1790. if codegenerror then
  1791. exit;
  1792. { load easier access variables }
  1793. rd:=right.resulttype.def;
  1794. ld:=left.resulttype.def;
  1795. rt:=right.nodetype;
  1796. lt:=left.nodetype;
  1797. { int/int gives real/real! }
  1798. if nodetype=slashn then
  1799. begin
  1800. {$ifdef cpufpemu}
  1801. result := first_addfloat;
  1802. if assigned(result) then
  1803. exit;
  1804. {$endif cpufpemu}
  1805. expectloc:=LOC_FPUREGISTER;
  1806. { maybe we need an integer register to save }
  1807. { a reference }
  1808. if ((left.expectloc<>LOC_FPUREGISTER) or
  1809. (right.expectloc<>LOC_FPUREGISTER)) and
  1810. (left.registersint=right.registersint) then
  1811. calcregisters(self,1,1,0)
  1812. else
  1813. calcregisters(self,0,1,0);
  1814. { an add node always first loads both the left and the }
  1815. { right in the fpu before doing the calculation. However, }
  1816. { calcregisters(0,2,0) will overestimate the number of }
  1817. { necessary registers (it will make it 3 in case one of }
  1818. { the operands is already in the fpu) (JM) }
  1819. if ((left.expectloc<>LOC_FPUREGISTER) or
  1820. (right.expectloc<>LOC_FPUREGISTER)) and
  1821. (registersfpu < 2) then
  1822. inc(registersfpu);
  1823. end
  1824. { if both are orddefs then check sub types }
  1825. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  1826. begin
  1827. { 2 booleans ? }
  1828. if is_boolean(ld) and is_boolean(rd) then
  1829. begin
  1830. if not(cs_full_boolean_eval in aktlocalswitches) and
  1831. (nodetype in [andn,orn]) then
  1832. begin
  1833. expectloc:=LOC_JUMP;
  1834. calcregisters(self,0,0,0);
  1835. end
  1836. else
  1837. begin
  1838. if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
  1839. begin
  1840. expectloc:=LOC_FLAGS;
  1841. if (left.expectloc in [LOC_JUMP,LOC_FLAGS]) and
  1842. (left.expectloc in [LOC_JUMP,LOC_FLAGS]) then
  1843. calcregisters(self,2,0,0)
  1844. else
  1845. calcregisters(self,1,0,0);
  1846. end
  1847. else
  1848. begin
  1849. expectloc:=LOC_REGISTER;
  1850. calcregisters(self,0,0,0);
  1851. end;
  1852. end;
  1853. end
  1854. else
  1855. { Both are chars? only convert to shortstrings for addn }
  1856. if is_char(ld) then
  1857. begin
  1858. if nodetype=addn then
  1859. internalerror(200103291);
  1860. expectloc:=LOC_FLAGS;
  1861. calcregisters(self,1,0,0);
  1862. end
  1863. {$ifndef cpu64bit}
  1864. { is there a 64 bit type ? }
  1865. else if (torddef(ld).typ in [s64bit,u64bit,scurrency]) then
  1866. begin
  1867. result := first_add64bitint;
  1868. if assigned(result) then
  1869. exit;
  1870. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1871. expectloc:=LOC_REGISTER
  1872. else
  1873. expectloc:=LOC_JUMP;
  1874. calcregisters(self,2,0,0)
  1875. end
  1876. {$endif cpu64bit}
  1877. { is there a cardinal? }
  1878. else if (torddef(ld).typ=u32bit) then
  1879. begin
  1880. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1881. expectloc:=LOC_REGISTER
  1882. else
  1883. expectloc:=LOC_FLAGS;
  1884. calcregisters(self,1,0,0);
  1885. { for unsigned mul we need an extra register }
  1886. if nodetype=muln then
  1887. inc(registersint);
  1888. end
  1889. { generic s32bit conversion }
  1890. else
  1891. begin
  1892. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1893. expectloc:=LOC_REGISTER
  1894. else
  1895. expectloc:=LOC_FLAGS;
  1896. calcregisters(self,1,0,0);
  1897. end;
  1898. end
  1899. { left side a setdef, must be before string processing,
  1900. else array constructor can be seen as array of char (PFV) }
  1901. else if (ld.deftype=setdef) then
  1902. begin
  1903. if tsetdef(ld).settype=smallset then
  1904. begin
  1905. if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
  1906. expectloc:=LOC_FLAGS
  1907. else
  1908. expectloc:=LOC_REGISTER;
  1909. { are we adding set elements ? }
  1910. if right.nodetype=setelementn then
  1911. calcregisters(self,2,0,0)
  1912. else
  1913. calcregisters(self,1,0,0);
  1914. end
  1915. else
  1916. {$ifdef MMXSET}
  1917. {$ifdef i386}
  1918. if cs_mmx in aktlocalswitches then
  1919. begin
  1920. expectloc:=LOC_MMXREGISTER;
  1921. calcregisters(self,0,0,4);
  1922. end
  1923. else
  1924. {$endif}
  1925. {$endif MMXSET}
  1926. begin
  1927. result := first_addset;
  1928. if assigned(result) then
  1929. exit;
  1930. expectloc:=LOC_CREFERENCE;
  1931. calcregisters(self,0,0,0);
  1932. { here we call SET... }
  1933. include(current_procinfo.flags,pi_do_call);
  1934. end;
  1935. end
  1936. { compare pchar by addresses like BP/Delphi }
  1937. else if is_pchar(ld) then
  1938. begin
  1939. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1940. expectloc:=LOC_REGISTER
  1941. else
  1942. expectloc:=LOC_FLAGS;
  1943. calcregisters(self,1,0,0);
  1944. end
  1945. { is one of the operands a string }
  1946. else if (ld.deftype=stringdef) then
  1947. begin
  1948. if is_widestring(ld) then
  1949. begin
  1950. { this is only for add, the comparisaion is handled later }
  1951. expectloc:=LOC_REGISTER;
  1952. end
  1953. else if is_ansistring(ld) then
  1954. begin
  1955. { this is only for add, the comparisaion is handled later }
  1956. expectloc:=LOC_REGISTER;
  1957. end
  1958. else if is_longstring(ld) then
  1959. begin
  1960. { this is only for add, the comparisaion is handled later }
  1961. expectloc:=LOC_REFERENCE;
  1962. end
  1963. else
  1964. begin
  1965. {$ifdef addstringopt}
  1966. { can create a call which isn't handled by callparatemp }
  1967. if canbeaddsstringcharoptnode(self) then
  1968. begin
  1969. hp := genaddsstringcharoptnode(self);
  1970. pass_1 := hp;
  1971. exit;
  1972. end
  1973. else
  1974. {$endif addstringopt}
  1975. begin
  1976. { Fix right to be shortstring }
  1977. if is_char(right.resulttype.def) then
  1978. begin
  1979. inserttypeconv(right,cshortstringtype);
  1980. firstpass(right);
  1981. end;
  1982. end;
  1983. {$ifdef addstringopt}
  1984. { can create a call which isn't handled by callparatemp }
  1985. if canbeaddsstringcsstringoptnode(self) then
  1986. begin
  1987. hp := genaddsstringcsstringoptnode(self);
  1988. pass_1 := hp;
  1989. exit;
  1990. end;
  1991. {$endif addstringopt}
  1992. end;
  1993. { otherwise, let addstring convert everything }
  1994. result := first_addstring;
  1995. exit;
  1996. end
  1997. { is one a real float ? }
  1998. else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
  1999. begin
  2000. {$ifdef cpufpemu}
  2001. result := first_addfloat;
  2002. if assigned(result) then
  2003. exit;
  2004. {$endif cpufpemu}
  2005. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2006. expectloc:=LOC_FPUREGISTER
  2007. else
  2008. expectloc:=LOC_FLAGS;
  2009. calcregisters(self,0,1,0);
  2010. { an add node always first loads both the left and the }
  2011. { right in the fpu before doing the calculation. However, }
  2012. { calcregisters(0,2,0) will overestimate the number of }
  2013. { necessary registers (it will make it 3 in case one of }
  2014. { the operands is already in the fpu) (JM) }
  2015. if ((left.expectloc<>LOC_FPUREGISTER) or
  2016. (right.expectloc<>LOC_FPUREGISTER)) and
  2017. (registersfpu < 2) then
  2018. inc(registersfpu);
  2019. end
  2020. { pointer comperation and subtraction }
  2021. else if (ld.deftype=pointerdef) then
  2022. begin
  2023. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2024. expectloc:=LOC_REGISTER
  2025. else
  2026. expectloc:=LOC_FLAGS;
  2027. calcregisters(self,1,0,0);
  2028. end
  2029. else if is_class_or_interface(ld) then
  2030. begin
  2031. expectloc:=LOC_FLAGS;
  2032. calcregisters(self,1,0,0);
  2033. end
  2034. else if (ld.deftype=classrefdef) then
  2035. begin
  2036. expectloc:=LOC_FLAGS;
  2037. calcregisters(self,1,0,0);
  2038. end
  2039. { support procvar=nil,procvar<>nil }
  2040. else if ((ld.deftype=procvardef) and (rt=niln)) or
  2041. ((rd.deftype=procvardef) and (lt=niln)) then
  2042. begin
  2043. expectloc:=LOC_FLAGS;
  2044. calcregisters(self,1,0,0);
  2045. end
  2046. {$ifdef SUPPORT_MMX}
  2047. { mmx support, this must be before the zero based array
  2048. check }
  2049. else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
  2050. is_mmx_able_array(rd) then
  2051. begin
  2052. expectloc:=LOC_MMXREGISTER;
  2053. calcregisters(self,0,0,1);
  2054. end
  2055. {$endif SUPPORT_MMX}
  2056. else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
  2057. begin
  2058. expectloc:=LOC_REGISTER;
  2059. calcregisters(self,1,0,0);
  2060. end
  2061. else if (rd.deftype=procvardef) and
  2062. (ld.deftype=procvardef) and
  2063. equal_defs(rd,ld) then
  2064. begin
  2065. expectloc:=LOC_FLAGS;
  2066. calcregisters(self,1,0,0);
  2067. end
  2068. else if (ld.deftype=enumdef) then
  2069. begin
  2070. expectloc:=LOC_FLAGS;
  2071. calcregisters(self,1,0,0);
  2072. end
  2073. {$ifdef SUPPORT_MMX}
  2074. else if (cs_mmx in aktlocalswitches) and
  2075. is_mmx_able_array(ld) and
  2076. is_mmx_able_array(rd) then
  2077. begin
  2078. expectloc:=LOC_MMXREGISTER;
  2079. calcregisters(self,0,0,1);
  2080. end
  2081. {$endif SUPPORT_MMX}
  2082. { the general solution is to convert to 32 bit int }
  2083. else
  2084. begin
  2085. expectloc:=LOC_REGISTER;
  2086. calcregisters(self,1,0,0);
  2087. end;
  2088. end;
  2089. {$ifdef state_tracking}
  2090. function Taddnode.track_state_pass(exec_known:boolean):boolean;
  2091. var factval:Tnode;
  2092. begin
  2093. track_state_pass:=false;
  2094. if left.track_state_pass(exec_known) then
  2095. begin
  2096. track_state_pass:=true;
  2097. left.resulttype.def:=nil;
  2098. do_resulttypepass(left);
  2099. end;
  2100. factval:=aktstate.find_fact(left);
  2101. if factval<>nil then
  2102. begin
  2103. track_state_pass:=true;
  2104. left.destroy;
  2105. left:=factval.getcopy;
  2106. end;
  2107. if right.track_state_pass(exec_known) then
  2108. begin
  2109. track_state_pass:=true;
  2110. right.resulttype.def:=nil;
  2111. do_resulttypepass(right);
  2112. end;
  2113. factval:=aktstate.find_fact(right);
  2114. if factval<>nil then
  2115. begin
  2116. track_state_pass:=true;
  2117. right.destroy;
  2118. right:=factval.getcopy;
  2119. end;
  2120. end;
  2121. {$endif}
  2122. begin
  2123. caddnode:=taddnode;
  2124. end.