nadd.pas 88 KB

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