nadd.pas 88 KB

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