nadd.pas 67 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 defines.inc}
  20. interface
  21. uses
  22. node;
  23. type
  24. taddnode = class(tbinopnode)
  25. constructor create(tt : tnodetype;l,r : tnode);override;
  26. function pass_1 : tnode;override;
  27. function det_resulttype:tnode;override;
  28. protected
  29. { override the following if you want to implement }
  30. { parts explicitely in the code generator (JM) }
  31. function first_addstring: tnode; virtual;
  32. function first_addset: tnode; virtual;
  33. { only implements "muln" nodes, the rest always has to be done in }
  34. { the code generator for performance reasons (JM) }
  35. function first_add64bitint: tnode; virtual;
  36. end;
  37. taddnodeclass = class of taddnode;
  38. var
  39. { caddnode is used to create nodes of the add type }
  40. { the virtual constructor allows to assign }
  41. { another class type to caddnode => processor }
  42. { specific node types can be created }
  43. caddnode : taddnodeclass;
  44. implementation
  45. uses
  46. globtype,systems,
  47. cutils,verbose,globals,widestr,
  48. symconst,symtype,symbase,symdef,symsym,symtable,types,
  49. cpuinfo,
  50. cgbase,
  51. htypechk,pass_1,
  52. nmat,ncnv,nld,ncon,nset,nopt,ncal,ninl,
  53. cpubase;
  54. {*****************************************************************************
  55. TADDNODE
  56. *****************************************************************************}
  57. {$ifdef fpc}
  58. {$maxfpuregisters 0}
  59. {$endif fpc}
  60. constructor taddnode.create(tt : tnodetype;l,r : tnode);
  61. begin
  62. inherited create(tt,l,r);
  63. end;
  64. function taddnode.det_resulttype:tnode;
  65. var
  66. hp,t : tnode;
  67. lt,rt : tnodetype;
  68. rd,ld : tdef;
  69. htype : ttype;
  70. ot : tnodetype;
  71. concatstrings : boolean;
  72. resultset : pconstset;
  73. i : longint;
  74. b : boolean;
  75. s1,s2 : pchar;
  76. ws1,ws2 : pcompilerwidestring;
  77. l1,l2 : longint;
  78. rv,lv : tconstexprint;
  79. rvd,lvd : bestreal;
  80. begin
  81. result:=nil;
  82. { first do the two subtrees }
  83. resulttypepass(left);
  84. resulttypepass(right);
  85. { both left and right need to be valid }
  86. set_varstate(left,true);
  87. set_varstate(right,true);
  88. if codegenerror then
  89. exit;
  90. { convert array constructors to sets, because there is no other operator
  91. possible for array constructors }
  92. if is_array_constructor(left.resulttype.def) then
  93. begin
  94. arrayconstructor_to_set(tarrayconstructornode(left));
  95. resulttypepass(left);
  96. end;
  97. if is_array_constructor(right.resulttype.def) then
  98. begin
  99. arrayconstructor_to_set(tarrayconstructornode(right));
  100. resulttypepass(right);
  101. end;
  102. { allow operator overloading }
  103. hp:=self;
  104. if isbinaryoverloaded(hp) then
  105. begin
  106. result:=hp;
  107. exit;
  108. end;
  109. { Kylix allows enum+ordconstn in an enum declaration (blocktype
  110. is bt_type), we need to do the conversion here before the
  111. constant folding }
  112. if (m_delphi in aktmodeswitches) and
  113. (blocktype=bt_type) then
  114. begin
  115. if (left.resulttype.def.deftype=enumdef) and
  116. (right.resulttype.def.deftype=orddef) then
  117. begin
  118. { insert explicit typecast to s32bit }
  119. left:=ctypeconvnode.create(left,s32bittype);
  120. include(left.flags,nf_explizit);
  121. resulttypepass(left);
  122. end
  123. else
  124. if (left.resulttype.def.deftype=orddef) and
  125. (right.resulttype.def.deftype=enumdef) then
  126. begin
  127. { insert explicit typecast to s32bit }
  128. right:=ctypeconvnode.create(right,s32bittype);
  129. include(right.flags,nf_explizit);
  130. resulttypepass(right);
  131. end;
  132. end;
  133. { is one a real float, then both need to be floats, this
  134. need to be done before the constant folding so constant
  135. operation on a float and int are also handled }
  136. if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then
  137. begin
  138. inserttypeconv(right,pbestrealtype^);
  139. inserttypeconv(left,pbestrealtype^);
  140. end;
  141. { if one operand is a widechar or a widestring, both operands }
  142. { are converted to widestring. This must be done before constant }
  143. { folding to allow char+widechar etc. }
  144. if is_widestring(right.resulttype.def) or
  145. is_widestring(left.resulttype.def) or
  146. is_widechar(right.resulttype.def) or
  147. is_widechar(left.resulttype.def) then
  148. begin
  149. inserttypeconv(right,cwidestringtype);
  150. inserttypeconv(left,cwidestringtype);
  151. end;
  152. { load easier access variables }
  153. rd:=right.resulttype.def;
  154. ld:=left.resulttype.def;
  155. rt:=right.nodetype;
  156. lt:=left.nodetype;
  157. { both are int constants }
  158. if (((is_constintnode(left) and is_constintnode(right)) or
  159. (is_constboolnode(left) and is_constboolnode(right) and
  160. (nodetype in [ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])))) or
  161. { support pointer arithmetics on constants (JM) }
  162. ((lt = pointerconstn) and is_constintnode(right) and
  163. (nodetype in [addn,subn])) or
  164. ((lt = pointerconstn) and (rt = pointerconstn) and
  165. (nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])) then
  166. begin
  167. { when comparing/substracting pointers, make sure they are }
  168. { of the same type (JM) }
  169. if (lt = pointerconstn) and (rt = pointerconstn) then
  170. begin
  171. if not(cs_extsyntax in aktmoduleswitches) and
  172. not(nodetype in [equaln,unequaln]) then
  173. CGMessage(type_e_mismatch)
  174. else
  175. if (nodetype <> subn) and
  176. is_voidpointer(rd) then
  177. inserttypeconv(right,left.resulttype)
  178. else if (nodetype <> subn) and
  179. is_voidpointer(ld) then
  180. inserttypeconv(left,right.resulttype)
  181. else if not(is_equal(ld,rd)) then
  182. CGMessage(type_e_mismatch);
  183. end
  184. else if (lt=ordconstn) and (rt=ordconstn) then
  185. begin
  186. { make left const type the biggest, this type will be used
  187. for orn,andn,xorn }
  188. if rd.size>ld.size then
  189. inserttypeconv(left,right.resulttype);
  190. end;
  191. { load values }
  192. if (lt = ordconstn) then
  193. lv:=tordconstnode(left).value
  194. else
  195. lv:=tpointerconstnode(left).value;
  196. if (rt = ordconstn) then
  197. rv:=tordconstnode(right).value
  198. else
  199. rv:=tpointerconstnode(right).value;
  200. if (lt = pointerconstn) and
  201. (rt <> pointerconstn) then
  202. rv := rv * tpointerdef(left.resulttype.def).pointertype.def.size;
  203. if (rt = pointerconstn) and
  204. (lt <> pointerconstn) then
  205. lv := lv * tpointerdef(right.resulttype.def).pointertype.def.size;
  206. case nodetype of
  207. addn :
  208. if (lt <> pointerconstn) then
  209. t := genintconstnode(lv+rv)
  210. else
  211. t := cpointerconstnode.create(lv+rv,left.resulttype);
  212. subn :
  213. if (lt <> pointerconstn) or (rt = pointerconstn) then
  214. t := genintconstnode(lv-rv)
  215. else
  216. t := cpointerconstnode.create(lv-rv,left.resulttype);
  217. muln :
  218. t:=genintconstnode(lv*rv);
  219. xorn :
  220. t:=cordconstnode.create(lv xor rv,left.resulttype);
  221. orn :
  222. t:=cordconstnode.create(lv or rv,left.resulttype);
  223. andn :
  224. t:=cordconstnode.create(lv and rv,left.resulttype);
  225. ltn :
  226. t:=cordconstnode.create(ord(lv<rv),booltype);
  227. lten :
  228. t:=cordconstnode.create(ord(lv<=rv),booltype);
  229. gtn :
  230. t:=cordconstnode.create(ord(lv>rv),booltype);
  231. gten :
  232. t:=cordconstnode.create(ord(lv>=rv),booltype);
  233. equaln :
  234. t:=cordconstnode.create(ord(lv=rv),booltype);
  235. unequaln :
  236. t:=cordconstnode.create(ord(lv<>rv),booltype);
  237. slashn :
  238. begin
  239. { int/int becomes a real }
  240. rvd:=rv;
  241. lvd:=lv;
  242. if int(rvd)=0 then
  243. begin
  244. Message(parser_e_invalid_float_operation);
  245. t:=crealconstnode.create(0,pbestrealtype^);
  246. end
  247. else
  248. t:=crealconstnode.create(int(lvd)/int(rvd),pbestrealtype^);
  249. end;
  250. else
  251. CGMessage(type_e_mismatch);
  252. end;
  253. result:=t;
  254. exit;
  255. end;
  256. { both real constants ? }
  257. if (lt=realconstn) and (rt=realconstn) then
  258. begin
  259. lvd:=trealconstnode(left).value_real;
  260. rvd:=trealconstnode(right).value_real;
  261. case nodetype of
  262. addn :
  263. t:=crealconstnode.create(lvd+rvd,pbestrealtype^);
  264. subn :
  265. t:=crealconstnode.create(lvd-rvd,pbestrealtype^);
  266. muln :
  267. t:=crealconstnode.create(lvd*rvd,pbestrealtype^);
  268. starstarn,
  269. caretn :
  270. begin
  271. if lvd<0 then
  272. begin
  273. Message(parser_e_invalid_float_operation);
  274. t:=crealconstnode.create(0,pbestrealtype^);
  275. end
  276. else if lvd=0 then
  277. t:=crealconstnode.create(1.0,pbestrealtype^)
  278. else
  279. t:=crealconstnode.create(exp(ln(lvd)*rvd),pbestrealtype^);
  280. end;
  281. slashn :
  282. begin
  283. if rvd=0 then
  284. begin
  285. Message(parser_e_invalid_float_operation);
  286. t:=crealconstnode.create(0,pbestrealtype^);
  287. end
  288. else
  289. t:=crealconstnode.create(lvd/rvd,pbestrealtype^);
  290. end;
  291. ltn :
  292. t:=cordconstnode.create(ord(lvd<rvd),booltype);
  293. lten :
  294. t:=cordconstnode.create(ord(lvd<=rvd),booltype);
  295. gtn :
  296. t:=cordconstnode.create(ord(lvd>rvd),booltype);
  297. gten :
  298. t:=cordconstnode.create(ord(lvd>=rvd),booltype);
  299. equaln :
  300. t:=cordconstnode.create(ord(lvd=rvd),booltype);
  301. unequaln :
  302. t:=cordconstnode.create(ord(lvd<>rvd),booltype);
  303. else
  304. CGMessage(type_e_mismatch);
  305. end;
  306. result:=t;
  307. exit;
  308. end;
  309. { first, we handle widestrings, so we can check later for }
  310. { stringconstn only }
  311. { widechars are converted above to widestrings too }
  312. { this isn't veryy efficient, but I don't think }
  313. { that it does matter that much (FK) }
  314. if (lt=stringconstn) and (rt=stringconstn) and
  315. (tstringconstnode(left).st_type=st_widestring) and
  316. (tstringconstnode(right).st_type=st_widestring) then
  317. begin
  318. initwidestring(ws1);
  319. initwidestring(ws2);
  320. copywidestring(pcompilerwidestring(tstringconstnode(left).value_str),ws1);
  321. copywidestring(pcompilerwidestring(tstringconstnode(right).value_str),ws2);
  322. case nodetype of
  323. addn :
  324. begin
  325. concatwidestrings(ws1,ws2);
  326. t:=cstringconstnode.createwstr(ws1);
  327. end;
  328. ltn :
  329. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype);
  330. lten :
  331. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype);
  332. gtn :
  333. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype);
  334. gten :
  335. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype);
  336. equaln :
  337. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype);
  338. unequaln :
  339. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype);
  340. end;
  341. donewidestring(ws1);
  342. donewidestring(ws2);
  343. result:=t;
  344. exit;
  345. end;
  346. { concating strings ? }
  347. concatstrings:=false;
  348. s1:=nil;
  349. s2:=nil;
  350. if (lt=ordconstn) and (rt=ordconstn) and
  351. is_char(ld) and is_char(rd) then
  352. begin
  353. s1:=strpnew(char(byte(tordconstnode(left).value)));
  354. s2:=strpnew(char(byte(tordconstnode(right).value)));
  355. l1:=1;
  356. l2:=1;
  357. concatstrings:=true;
  358. end
  359. else
  360. if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
  361. begin
  362. s1:=tstringconstnode(left).getpcharcopy;
  363. l1:=tstringconstnode(left).len;
  364. s2:=strpnew(char(byte(tordconstnode(right).value)));
  365. l2:=1;
  366. concatstrings:=true;
  367. end
  368. else
  369. if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
  370. begin
  371. s1:=strpnew(char(byte(tordconstnode(left).value)));
  372. l1:=1;
  373. s2:=tstringconstnode(right).getpcharcopy;
  374. l2:=tstringconstnode(right).len;
  375. concatstrings:=true;
  376. end
  377. else if (lt=stringconstn) and (rt=stringconstn) then
  378. begin
  379. s1:=tstringconstnode(left).getpcharcopy;
  380. l1:=tstringconstnode(left).len;
  381. s2:=tstringconstnode(right).getpcharcopy;
  382. l2:=tstringconstnode(right).len;
  383. concatstrings:=true;
  384. end;
  385. if concatstrings then
  386. begin
  387. case nodetype of
  388. addn :
  389. t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
  390. ltn :
  391. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype);
  392. lten :
  393. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype);
  394. gtn :
  395. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype);
  396. gten :
  397. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype);
  398. equaln :
  399. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype);
  400. unequaln :
  401. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype);
  402. end;
  403. ansistringdispose(s1,l1);
  404. ansistringdispose(s2,l2);
  405. result:=t;
  406. exit;
  407. end;
  408. { set constant evaluation }
  409. if (right.nodetype=setconstn) and
  410. not assigned(tsetconstnode(right).left) and
  411. (left.nodetype=setconstn) and
  412. not assigned(tsetconstnode(left).left) then
  413. begin
  414. { check types }
  415. inserttypeconv(left,right.resulttype);
  416. if codegenerror then
  417. begin
  418. { recover by only returning the left part }
  419. result:=left;
  420. left:=nil;
  421. exit;
  422. end;
  423. new(resultset);
  424. case nodetype of
  425. addn :
  426. begin
  427. for i:=0 to 31 do
  428. resultset^[i]:=tsetconstnode(right).value_set^[i] or tsetconstnode(left).value_set^[i];
  429. t:=csetconstnode.create(resultset,left.resulttype);
  430. end;
  431. muln :
  432. begin
  433. for i:=0 to 31 do
  434. resultset^[i]:=tsetconstnode(right).value_set^[i] and tsetconstnode(left).value_set^[i];
  435. t:=csetconstnode.create(resultset,left.resulttype);
  436. end;
  437. subn :
  438. begin
  439. for i:=0 to 31 do
  440. resultset^[i]:=tsetconstnode(left).value_set^[i] and not(tsetconstnode(right).value_set^[i]);
  441. t:=csetconstnode.create(resultset,left.resulttype);
  442. end;
  443. symdifn :
  444. begin
  445. for i:=0 to 31 do
  446. resultset^[i]:=tsetconstnode(left).value_set^[i] xor tsetconstnode(right).value_set^[i];
  447. t:=csetconstnode.create(resultset,left.resulttype);
  448. end;
  449. unequaln :
  450. begin
  451. b:=true;
  452. for i:=0 to 31 do
  453. if tsetconstnode(right).value_set^[i]=tsetconstnode(left).value_set^[i] then
  454. begin
  455. b:=false;
  456. break;
  457. end;
  458. t:=cordconstnode.create(ord(b),booltype);
  459. end;
  460. equaln :
  461. begin
  462. b:=true;
  463. for i:=0 to 31 do
  464. if tsetconstnode(right).value_set^[i]<>tsetconstnode(left).value_set^[i] then
  465. begin
  466. b:=false;
  467. break;
  468. end;
  469. t:=cordconstnode.create(ord(b),booltype);
  470. end;
  471. lten :
  472. begin
  473. b := true;
  474. For i := 0 to 31 Do
  475. If (tsetconstnode(right).value_set^[i] And tsetconstnode(left).value_set^[i]) <>
  476. tsetconstnode(left).value_set^[i] Then
  477. Begin
  478. b := false;
  479. Break
  480. End;
  481. t := cordconstnode.create(ord(b),booltype);
  482. End;
  483. gten :
  484. Begin
  485. b := true;
  486. For i := 0 to 31 Do
  487. If (tsetconstnode(left).value_set^[i] And tsetconstnode(right).value_set^[i]) <>
  488. tsetconstnode(right).value_set^[i] Then
  489. Begin
  490. b := false;
  491. Break
  492. End;
  493. t := cordconstnode.create(ord(b),booltype);
  494. End;
  495. end;
  496. dispose(resultset);
  497. result:=t;
  498. exit;
  499. end;
  500. { but an int/int gives real/real! }
  501. if nodetype=slashn then
  502. begin
  503. CGMessage(type_h_use_div_for_int);
  504. inserttypeconv(right,pbestrealtype^);
  505. inserttypeconv(left,pbestrealtype^);
  506. end
  507. { if both are orddefs then check sub types }
  508. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  509. begin
  510. { 2 booleans? Make them equal to the largest boolean }
  511. if is_boolean(ld) and is_boolean(rd) then
  512. begin
  513. if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then
  514. begin
  515. inserttypeconv(right,left.resulttype);
  516. ttypeconvnode(right).convtype:=tc_bool_2_int;
  517. include(right.flags,nf_explizit);
  518. end
  519. else if torddef(left.resulttype.def).size<torddef(right.resulttype.def).size then
  520. begin
  521. inserttypeconv(left,right.resulttype);
  522. ttypeconvnode(left).convtype:=tc_bool_2_int;
  523. include(left.flags,nf_explizit);
  524. end;
  525. case nodetype of
  526. xorn,
  527. ltn,
  528. lten,
  529. gtn,
  530. gten,
  531. andn,
  532. orn:
  533. begin
  534. end;
  535. unequaln,
  536. equaln:
  537. begin
  538. if not(cs_full_boolean_eval in aktlocalswitches) then
  539. begin
  540. { Remove any compares with constants }
  541. if (left.nodetype=ordconstn) then
  542. begin
  543. hp:=right;
  544. b:=(tordconstnode(left).value<>0);
  545. ot:=nodetype;
  546. left.free;
  547. left:=nil;
  548. right:=nil;
  549. if (not(b) and (ot=equaln)) or
  550. (b and (ot=unequaln)) then
  551. begin
  552. hp:=cnotnode.create(hp);
  553. end;
  554. result:=hp;
  555. exit;
  556. end;
  557. if (right.nodetype=ordconstn) then
  558. begin
  559. hp:=left;
  560. b:=(tordconstnode(right).value<>0);
  561. ot:=nodetype;
  562. right.free;
  563. right:=nil;
  564. left:=nil;
  565. if (not(b) and (ot=equaln)) or
  566. (b and (ot=unequaln)) then
  567. begin
  568. hp:=cnotnode.create(hp);
  569. end;
  570. result:=hp;
  571. exit;
  572. end;
  573. end;
  574. end;
  575. else
  576. CGMessage(type_e_mismatch);
  577. end;
  578. end
  579. { Both are chars? }
  580. else if is_char(rd) and is_char(ld) then
  581. begin
  582. if nodetype=addn then
  583. begin
  584. resulttype:=cshortstringtype;
  585. if not(is_constcharnode(left) and is_constcharnode(right)) then
  586. begin
  587. inserttypeconv(left,cshortstringtype);
  588. hp := genaddsstringcharoptnode(self);
  589. result := hp;
  590. exit;
  591. end;
  592. end;
  593. end
  594. { is there a signed 64 bit type ? }
  595. else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
  596. begin
  597. if (torddef(ld).typ<>s64bit) then
  598. inserttypeconv(left,cs64bittype);
  599. if (torddef(rd).typ<>s64bit) then
  600. inserttypeconv(right,cs64bittype);
  601. end
  602. { is there a unsigned 64 bit type ? }
  603. else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then
  604. begin
  605. if (torddef(ld).typ<>u64bit) then
  606. inserttypeconv(left,cu64bittype);
  607. if (torddef(rd).typ<>u64bit) then
  608. inserttypeconv(right,cu64bittype);
  609. end
  610. { is there a cardinal? }
  611. else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then
  612. begin
  613. if is_signed(ld) and
  614. { then rd = u32bit }
  615. { convert positive constants to u32bit }
  616. not(is_constintnode(left) and
  617. (tordconstnode(left).value >= 0)) and
  618. { range/overflow checking on mixed signed/cardinal expressions }
  619. { is only possible if you convert everything to 64bit (JM) }
  620. ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and
  621. (nodetype in [addn,subn,muln])) then
  622. begin
  623. { perform the operation in 64bit }
  624. CGMessage(type_w_mixed_signed_unsigned);
  625. inserttypeconv(left,cs64bittype);
  626. inserttypeconv(right,cs64bittype);
  627. end
  628. else
  629. begin
  630. if is_signed(ld) and
  631. not(is_constintnode(left) and
  632. (tordconstnode(left).value >= 0)) and
  633. (cs_check_range in aktlocalswitches) then
  634. CGMessage(type_w_mixed_signed_unsigned2);
  635. inserttypeconv(left,u32bittype);
  636. if is_signed(rd) and
  637. { then ld = u32bit }
  638. { convert positive constants to u32bit }
  639. not(is_constintnode(right) and
  640. (tordconstnode(right).value >= 0)) and
  641. ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and
  642. (nodetype in [addn,subn,muln])) then
  643. begin
  644. { perform the operation in 64bit }
  645. CGMessage(type_w_mixed_signed_unsigned);
  646. inserttypeconv(left,cs64bittype);
  647. inserttypeconv(right,cs64bittype);
  648. end
  649. else
  650. begin
  651. if is_signed(rd) and
  652. not(is_constintnode(right) and
  653. (tordconstnode(right).value >= 0)) and
  654. (cs_check_range in aktlocalswitches) then
  655. CGMessage(type_w_mixed_signed_unsigned2);
  656. inserttypeconv(right,u32bittype);
  657. end;
  658. end;
  659. end
  660. { generic ord conversion is s32bit }
  661. else
  662. begin
  663. inserttypeconv(right,s32bittype);
  664. inserttypeconv(left,s32bittype);
  665. end;
  666. end
  667. { if both are floatdefs, conversion is already done before constant folding }
  668. else if (ld.deftype=floatdef) then
  669. begin
  670. { already converted }
  671. end
  672. { left side a setdef, must be before string processing,
  673. else array constructor can be seen as array of char (PFV) }
  674. else if (ld.deftype=setdef) then
  675. begin
  676. { trying to add a set element? }
  677. if (nodetype=addn) and (rd.deftype<>setdef) then
  678. begin
  679. if (rt=setelementn) then
  680. begin
  681. if not(is_equal(tsetdef(ld).elementtype.def,rd)) then
  682. CGMessage(type_e_set_element_are_not_comp);
  683. end
  684. else
  685. CGMessage(type_e_mismatch)
  686. end
  687. else
  688. begin
  689. if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
  690. CGMessage(type_e_set_operation_unknown);
  691. { right def must be a also be set }
  692. if (rd.deftype<>setdef) or not(is_equal(rd,ld)) then
  693. CGMessage(type_e_set_element_are_not_comp);
  694. end;
  695. { ranges require normsets }
  696. if (tsetdef(ld).settype=smallset) and
  697. (rt=setelementn) and
  698. assigned(tsetelementnode(right).right) then
  699. begin
  700. { generate a temporary normset def, it'll be destroyed
  701. when the symtable is unloaded }
  702. htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
  703. inserttypeconv(left,htype);
  704. end;
  705. { if the destination is not a smallset then insert a typeconv
  706. which loads a smallset into a normal set }
  707. if (tsetdef(ld).settype<>smallset) and
  708. (tsetdef(rd).settype=smallset) then
  709. begin
  710. if (right.nodetype=setconstn) then
  711. begin
  712. t:=csetconstnode.create(tsetconstnode(right).value_set,left.resulttype);
  713. tsetconstnode(t).left:=tsetconstnode(right).left;
  714. tsetconstnode(right).left := nil;
  715. right.free;
  716. right:=t;
  717. end
  718. else
  719. inserttypeconv(right,left.resulttype);
  720. resulttypepass(right);
  721. end;
  722. end
  723. { compare pchar to char arrays by addresses like BP/Delphi }
  724. else if (is_pchar(ld) and is_chararray(rd)) or
  725. (is_pchar(rd) and is_chararray(ld)) then
  726. begin
  727. if is_chararray(rd) then
  728. inserttypeconv(right,left.resulttype)
  729. else
  730. inserttypeconv(left,right.resulttype);
  731. end
  732. { is one of the operands a string?,
  733. chararrays are also handled as strings (after conversion), also take
  734. care of chararray+chararray and chararray+char }
  735. else if (rd.deftype=stringdef) or (ld.deftype=stringdef) or
  736. ((is_chararray(rd) or is_char(rd)) and
  737. (is_chararray(ld) or is_char(ld))) then
  738. begin
  739. if is_widestring(rd) or is_widestring(ld) then
  740. begin
  741. if not(is_widestring(rd)) then
  742. inserttypeconv(right,cwidestringtype);
  743. if not(is_widestring(ld)) then
  744. inserttypeconv(left,cwidestringtype);
  745. end
  746. else if is_ansistring(rd) or is_ansistring(ld) then
  747. begin
  748. if not(is_ansistring(rd)) then
  749. inserttypeconv(right,cansistringtype);
  750. if not(is_ansistring(ld)) then
  751. inserttypeconv(left,cansistringtype);
  752. end
  753. else if is_longstring(rd) or is_longstring(ld) then
  754. begin
  755. if not(is_longstring(rd)) then
  756. inserttypeconv(right,clongstringtype);
  757. if not(is_longstring(ld)) then
  758. inserttypeconv(left,clongstringtype);
  759. location.loc:=LOC_MEM;
  760. end
  761. else
  762. begin
  763. if not(is_shortstring(ld)) then
  764. inserttypeconv(left,cshortstringtype);
  765. { don't convert char, that can be handled by the optimized node }
  766. if not(is_shortstring(rd) or is_char(rd)) then
  767. inserttypeconv(right,cshortstringtype);
  768. end;
  769. end
  770. { pointer comparision and subtraction }
  771. else if (rd.deftype=pointerdef) and (ld.deftype=pointerdef) then
  772. begin
  773. case nodetype of
  774. equaln,unequaln :
  775. begin
  776. if is_voidpointer(right.resulttype.def) then
  777. inserttypeconv(right,left.resulttype)
  778. else if is_voidpointer(left.resulttype.def) then
  779. inserttypeconv(left,right.resulttype)
  780. else if not(is_equal(ld,rd)) then
  781. CGMessage(type_e_mismatch);
  782. end;
  783. ltn,lten,gtn,gten:
  784. begin
  785. if (cs_extsyntax in aktmoduleswitches) then
  786. begin
  787. if is_voidpointer(right.resulttype.def) then
  788. inserttypeconv(right,left.resulttype)
  789. else if is_voidpointer(left.resulttype.def) then
  790. inserttypeconv(left,right.resulttype)
  791. else if not(is_equal(ld,rd)) then
  792. CGMessage(type_e_mismatch);
  793. end
  794. else
  795. CGMessage(type_e_mismatch);
  796. end;
  797. subn:
  798. begin
  799. if (cs_extsyntax in aktmoduleswitches) then
  800. begin
  801. if is_voidpointer(right.resulttype.def) then
  802. inserttypeconv(right,left.resulttype)
  803. else if is_voidpointer(left.resulttype.def) then
  804. inserttypeconv(left,right.resulttype)
  805. else if not(is_equal(ld,rd)) then
  806. CGMessage(type_e_mismatch);
  807. end
  808. else
  809. CGMessage(type_e_mismatch);
  810. resulttype:=s32bittype;
  811. exit;
  812. end;
  813. addn:
  814. begin
  815. if (cs_extsyntax in aktmoduleswitches) then
  816. begin
  817. if is_voidpointer(right.resulttype.def) then
  818. inserttypeconv(right,left.resulttype)
  819. else if is_voidpointer(left.resulttype.def) then
  820. inserttypeconv(left,right.resulttype)
  821. else if not(is_equal(ld,rd)) then
  822. CGMessage(type_e_mismatch);
  823. end
  824. else
  825. CGMessage(type_e_mismatch);
  826. resulttype:=s32bittype;
  827. exit;
  828. end;
  829. else
  830. CGMessage(type_e_mismatch);
  831. end;
  832. end
  833. { class or interface equation }
  834. else if is_class_or_interface(rd) or is_class_or_interface(ld) then
  835. begin
  836. if is_class_or_interface(rd) and is_class_or_interface(ld) then
  837. begin
  838. if tobjectdef(rd).is_related(tobjectdef(ld)) then
  839. inserttypeconv(right,left.resulttype)
  840. else
  841. inserttypeconv(left,right.resulttype);
  842. end
  843. else if is_class_or_interface(rd) then
  844. inserttypeconv(left,right.resulttype)
  845. else
  846. inserttypeconv(right,left.resulttype);
  847. if not(nodetype in [equaln,unequaln]) then
  848. CGMessage(type_e_mismatch);
  849. end
  850. else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
  851. begin
  852. if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
  853. tobjectdef(tclassrefdef(ld).pointertype.def)) then
  854. inserttypeconv(right,left.resulttype)
  855. else
  856. inserttypeconv(left,right.resulttype);
  857. if not(nodetype in [equaln,unequaln]) then
  858. CGMessage(type_e_mismatch);
  859. end
  860. { allows comperasion with nil pointer }
  861. else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
  862. begin
  863. inserttypeconv(left,right.resulttype);
  864. if not(nodetype in [equaln,unequaln]) then
  865. CGMessage(type_e_mismatch);
  866. end
  867. else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
  868. begin
  869. inserttypeconv(right,left.resulttype);
  870. if not(nodetype in [equaln,unequaln]) then
  871. CGMessage(type_e_mismatch);
  872. end
  873. { support procvar=nil,procvar<>nil }
  874. else if ((ld.deftype=procvardef) and (rt=niln)) or
  875. ((rd.deftype=procvardef) and (lt=niln)) then
  876. begin
  877. if not(nodetype in [equaln,unequaln]) then
  878. CGMessage(type_e_mismatch);
  879. end
  880. {$ifdef SUPPORT_MMX}
  881. { mmx support, this must be before the zero based array
  882. check }
  883. else if (cs_mmx in aktlocalswitches) and
  884. is_mmx_able_array(ld) and
  885. is_mmx_able_array(rd) and
  886. is_equal(ld,rd) then
  887. begin
  888. case nodetype of
  889. addn,subn,xorn,orn,andn:
  890. ;
  891. { mul is a little bit restricted }
  892. muln:
  893. if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
  894. CGMessage(type_e_mismatch);
  895. else
  896. CGMessage(type_e_mismatch);
  897. end;
  898. end
  899. {$endif SUPPORT_MMX}
  900. { this is a little bit dangerous, also the left type }
  901. { pointer to should be checked! This broke the mmx support }
  902. else if (rd.deftype=pointerdef) or is_zero_based_array(rd) then
  903. begin
  904. if is_zero_based_array(rd) then
  905. begin
  906. resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
  907. inserttypeconv(right,resulttype);
  908. end;
  909. inserttypeconv(left,s32bittype);
  910. if nodetype=addn then
  911. begin
  912. if not(cs_extsyntax in aktmoduleswitches) or
  913. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  914. CGMessage(type_e_mismatch);
  915. if (rd.deftype=pointerdef) and
  916. (tpointerdef(rd).pointertype.def.size>1) then
  917. left:=caddnode.create(muln,left,cordconstnode.create(tpointerdef(rd).pointertype.def.size,s32bittype));
  918. end
  919. else
  920. CGMessage(type_e_mismatch);
  921. end
  922. else if (ld.deftype=pointerdef) or is_zero_based_array(ld) then
  923. begin
  924. if is_zero_based_array(ld) then
  925. begin
  926. resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
  927. inserttypeconv(left,resulttype);
  928. end;
  929. inserttypeconv(right,s32bittype);
  930. if nodetype in [addn,subn] then
  931. begin
  932. if not(cs_extsyntax in aktmoduleswitches) or
  933. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  934. CGMessage(type_e_mismatch);
  935. if (ld.deftype=pointerdef) and
  936. (tpointerdef(ld).pointertype.def.size>1) then
  937. right:=caddnode.create(muln,right,cordconstnode.create(tpointerdef(ld).pointertype.def.size,s32bittype));
  938. end
  939. else
  940. CGMessage(type_e_mismatch);
  941. end
  942. else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then
  943. begin
  944. if not (nodetype in [equaln,unequaln]) then
  945. CGMessage(type_e_mismatch);
  946. end
  947. { enums }
  948. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  949. begin
  950. if not(is_equal(ld,rd)) then
  951. inserttypeconv(right,left.resulttype);
  952. if not(nodetype in [equaln,unequaln,ltn,lten,gtn,gten]) then
  953. CGMessage(type_e_mismatch);
  954. end
  955. { generic conversion, this is for error recovery }
  956. else
  957. begin
  958. inserttypeconv(left,s32bittype);
  959. inserttypeconv(right,s32bittype);
  960. end;
  961. { set resulttype if not already done }
  962. if not assigned(resulttype.def) then
  963. begin
  964. case nodetype of
  965. ltn,lten,gtn,gten,equaln,unequaln :
  966. resulttype:=booltype;
  967. slashn :
  968. resulttype:=pbestrealtype^;
  969. addn:
  970. begin
  971. { for strings, return is always a 255 char string }
  972. if is_shortstring(left.resulttype.def) then
  973. resulttype:=cshortstringtype
  974. else
  975. resulttype:=left.resulttype;
  976. end;
  977. else
  978. resulttype:=left.resulttype;
  979. end;
  980. end;
  981. end;
  982. function taddnode.first_addstring: tnode;
  983. var
  984. p: tnode;
  985. begin
  986. { when we get here, we are sure that both the left and the right }
  987. { node are both strings of the same stringtype (JM) }
  988. case nodetype of
  989. addn:
  990. begin
  991. { note: if you implemented an fpc_shortstr_concat similar to the }
  992. { one in i386.inc, you have to override first_addstring like in }
  993. { ti386addnode.first_string and implement the shortstring concat }
  994. { manually! The generic routine is different from the i386 one (JM) }
  995. { create the call to the concat routine both strings as arguments }
  996. result := ccallnode.createintern('fpc_'+
  997. lower(tstringdef(resulttype.def).stringtypname)+'_concat',
  998. ccallparanode.create(right,ccallparanode.create(left,nil)));
  999. { we reused the arguments }
  1000. left := nil;
  1001. right := nil;
  1002. firstpass(result);
  1003. end;
  1004. ltn,lten,gtn,gten,equaln,unequaln :
  1005. begin
  1006. { generate better code for s='' and s<>'' }
  1007. if (nodetype in [equaln,unequaln]) and
  1008. (((left.nodetype=stringconstn) and (str_length(left)=0)) or
  1009. ((right.nodetype=stringconstn) and (str_length(right)=0))) then
  1010. begin
  1011. { switch so that the constant is always on the right }
  1012. if left.nodetype = stringconstn then
  1013. begin
  1014. p := left;
  1015. left := right;
  1016. right := p;
  1017. end;
  1018. if is_shortstring(left.resulttype.def) then
  1019. { compare the length with 0 }
  1020. result := caddnode.create(nodetype,
  1021. cinlinenode.create(in_length_x,false,left),
  1022. cordconstnode.create(0,s32bittype))
  1023. else
  1024. begin
  1025. { compare the pointer with nil (for ansistrings etc), }
  1026. { faster than getting the length (JM) }
  1027. result:= caddnode.create(nodetype,
  1028. ctypeconvnode.create(left,voidpointertype),
  1029. cpointerconstnode.create(0,voidpointertype));
  1030. taddnode(result).left.toggleflag(nf_explizit);
  1031. end;
  1032. { left is reused }
  1033. left := nil;
  1034. { right isn't }
  1035. right.free;
  1036. right := nil;
  1037. firstpass(result);
  1038. exit;
  1039. end;
  1040. { no string constant -> call compare routine }
  1041. result := ccallnode.createintern('fpc_'+
  1042. lower(tstringdef(left.resulttype.def).stringtypname)+'_compare',
  1043. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1044. { and compare its result with 0 according to the original operator }
  1045. result := caddnode.create(nodetype,result,
  1046. cordconstnode.create(0,s32bittype));
  1047. left := nil;
  1048. right := nil;
  1049. firstpass(result);
  1050. end;
  1051. end;
  1052. end;
  1053. function taddnode.first_addset: tnode;
  1054. var
  1055. procname: string[31];
  1056. tempn: tnode;
  1057. paras: tcallparanode;
  1058. srsym: ttypesym;
  1059. createset: boolean;
  1060. begin
  1061. { get the sym that represents the fpc_normal_set type }
  1062. if not searchsystype('FPC_NORMAL_SET',srsym) then
  1063. internalerror(200108313);
  1064. case nodetype of
  1065. equaln,unequaln,lten,gten:
  1066. begin
  1067. case nodetype of
  1068. equaln,unequaln:
  1069. procname := 'fpc_set_comp_sets';
  1070. lten,gten:
  1071. begin
  1072. procname := 'fpc_set_contains_sets';
  1073. { (left >= right) = (right <= left) }
  1074. if nodetype = gten then
  1075. begin
  1076. tempn := left;
  1077. left := right;
  1078. right := tempn;
  1079. end;
  1080. end;
  1081. end;
  1082. { convert the arguments (explicitely) to fpc_normal_set's }
  1083. left := ctypeconvnode.create(left,srsym.restype);
  1084. left.toggleflag(nf_explizit);
  1085. right := ctypeconvnode.create(right,srsym.restype);
  1086. right.toggleflag(nf_explizit);
  1087. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1088. ccallparanode.create(left,nil)));
  1089. { left and right are reused as parameters }
  1090. left := nil;
  1091. right := nil;
  1092. { for an unequaln, we have to negate the result of comp_sets }
  1093. if nodetype = unequaln then
  1094. result := cnotnode.create(result);
  1095. end;
  1096. addn:
  1097. begin
  1098. { optimize first loading of a set }
  1099. if (right.nodetype=setelementn) and
  1100. not(assigned(tsetelementnode(right).right)) and
  1101. is_emptyset(left) then
  1102. begin
  1103. { type cast the value to pass as argument to a byte, }
  1104. { since that's what the helper expects }
  1105. tsetelementnode(right).left :=
  1106. ctypeconvnode.create(tsetelementnode(right).left,u8bittype);
  1107. tsetelementnode(right).left.toggleflag(nf_explizit);
  1108. { set the resulttype to the actual one (otherwise it's }
  1109. { "fpc_normal_set") }
  1110. result := ccallnode.createinternres('fpc_set_create_element',
  1111. ccallparanode.create(tsetelementnode(right).left,nil),
  1112. resulttype);
  1113. { reused }
  1114. tsetelementnode(right).left := nil;
  1115. end
  1116. else
  1117. begin
  1118. if right.nodetype=setelementn then
  1119. begin
  1120. { convert the arguments to bytes, since that's what }
  1121. { the helper expects }
  1122. tsetelementnode(right).left :=
  1123. ctypeconvnode.create(tsetelementnode(right).left,
  1124. u8bittype);
  1125. tsetelementnode(right).left.toggleflag(nf_explizit);
  1126. { convert the original set (explicitely) to an }
  1127. { fpc_normal_set so we can pass it to the helper }
  1128. left := ctypeconvnode.create(left,srsym.restype);
  1129. left.toggleflag(nf_explizit);
  1130. { add a range or a single element? }
  1131. if assigned(tsetelementnode(right).right) then
  1132. begin
  1133. tsetelementnode(right).right :=
  1134. ctypeconvnode.create(tsetelementnode(right).right,
  1135. u8bittype);
  1136. tsetelementnode(right).right.toggleflag(nf_explizit);
  1137. { create the call }
  1138. result := ccallnode.createinternres('fpc_set_set_range',
  1139. ccallparanode.create(tsetelementnode(right).right,
  1140. ccallparanode.create(tsetelementnode(right).left,
  1141. ccallparanode.create(left,nil))),resulttype);
  1142. end
  1143. else
  1144. begin
  1145. result := ccallnode.createinternres('fpc_set_set_byte',
  1146. ccallparanode.create(tsetelementnode(right).left,
  1147. ccallparanode.create(left,nil)),resulttype);
  1148. end;
  1149. { remove reused parts from original node }
  1150. tsetelementnode(right).right := nil;
  1151. tsetelementnode(right).left := nil;
  1152. left := nil;
  1153. end
  1154. else
  1155. begin
  1156. { add two sets }
  1157. { convert the sets to fpc_normal_set's }
  1158. left := ctypeconvnode.create(left,srsym.restype);
  1159. left.toggleflag(nf_explizit);
  1160. right := ctypeconvnode.create(right,srsym.restype);
  1161. right.toggleflag(nf_explizit);
  1162. result := ccallnode.createinternres('fpc_set_add_sets',
  1163. ccallparanode.create(right,
  1164. ccallparanode.create(left,nil)),resulttype);
  1165. { remove reused parts from original node }
  1166. left := nil;
  1167. right := nil;
  1168. end;
  1169. end
  1170. end;
  1171. subn,symdifn,muln:
  1172. begin
  1173. { convert the sets to fpc_normal_set's }
  1174. left := ctypeconvnode.create(left,srsym.restype);
  1175. left.toggleflag(nf_explizit);
  1176. right := ctypeconvnode.create(right,srsym.restype);
  1177. right.toggleflag(nf_explizit);
  1178. paras := ccallparanode.create(right,
  1179. ccallparanode.create(left,nil));
  1180. case nodetype of
  1181. subn:
  1182. result := ccallnode.createinternres('fpc_set_sub_sets',
  1183. paras,resulttype);
  1184. symdifn:
  1185. result := ccallnode.createinternres('fpc_set_symdif_sets',
  1186. paras,resulttype);
  1187. muln:
  1188. result := ccallnode.createinternres('fpc_set_mul_sets',
  1189. paras,resulttype);
  1190. end;
  1191. { remove reused parts from original node }
  1192. left := nil;
  1193. right := nil;
  1194. end;
  1195. else
  1196. internalerror(200108311);
  1197. end;
  1198. firstpass(result);
  1199. end;
  1200. function taddnode.first_add64bitint: tnode;
  1201. var
  1202. procname: string[31];
  1203. temp: tnode;
  1204. power: longint;
  1205. begin
  1206. result := nil;
  1207. { create helper calls mul }
  1208. if nodetype <> muln then
  1209. exit;
  1210. { make sure that if there is a constant, that it's on the right }
  1211. if left.nodetype = ordconstn then
  1212. begin
  1213. temp := right;
  1214. right := left;
  1215. left := temp;
  1216. end;
  1217. { can we use a shift instead of a mul? }
  1218. if (right.nodetype = ordconstn) and
  1219. ispowerof2(tordconstnode(right).value,power) then
  1220. begin
  1221. tordconstnode(right).value := power;
  1222. result := cshlshrnode.create(shln,left,right);
  1223. { left and right are reused }
  1224. left := nil;
  1225. right := nil;
  1226. { return firstpassed new node }
  1227. firstpass(result);
  1228. exit;
  1229. end;
  1230. { otherwise, create the parameters for the helper }
  1231. right := ccallparanode.create(
  1232. cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype),
  1233. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1234. left := nil;
  1235. if torddef(resulttype.def).typ = s64bit then
  1236. procname := 'fpc_mul_int64'
  1237. else
  1238. procname := 'fpc_mul_qword';
  1239. result := ccallnode.createintern(procname,right);
  1240. right := nil;
  1241. firstpass(result);
  1242. end;
  1243. function taddnode.pass_1 : tnode;
  1244. var
  1245. hp : tnode;
  1246. lt,rt : tnodetype;
  1247. rd,ld : tdef;
  1248. begin
  1249. result:=nil;
  1250. { first do the two subtrees }
  1251. firstpass(left);
  1252. firstpass(right);
  1253. if codegenerror then
  1254. exit;
  1255. { load easier access variables }
  1256. rd:=right.resulttype.def;
  1257. ld:=left.resulttype.def;
  1258. rt:=right.nodetype;
  1259. lt:=left.nodetype;
  1260. { int/int gives real/real! }
  1261. if nodetype=slashn then
  1262. begin
  1263. { maybe we need an integer register to save }
  1264. { a reference }
  1265. if ((left.location.loc<>LOC_FPU) or
  1266. (right.location.loc<>LOC_FPU)) and
  1267. (left.registers32=right.registers32) then
  1268. calcregisters(self,1,1,0)
  1269. else
  1270. calcregisters(self,0,1,0);
  1271. location.loc:=LOC_FPU;
  1272. end
  1273. { if both are orddefs then check sub types }
  1274. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  1275. begin
  1276. { 2 booleans ? }
  1277. if is_boolean(ld) and is_boolean(rd) then
  1278. begin
  1279. if not(cs_full_boolean_eval in aktlocalswitches) and
  1280. (nodetype in [andn,orn]) then
  1281. begin
  1282. calcregisters(self,0,0,0);
  1283. location.loc:=LOC_JUMP;
  1284. end
  1285. else
  1286. begin
  1287. if (left.location.loc in [LOC_JUMP,LOC_FLAGS]) and
  1288. (left.location.loc in [LOC_JUMP,LOC_FLAGS]) then
  1289. calcregisters(self,2,0,0)
  1290. else
  1291. calcregisters(self,1,0,0);
  1292. end;
  1293. end
  1294. else
  1295. { Both are chars? only convert to shortstrings for addn }
  1296. if is_char(ld) then
  1297. begin
  1298. if nodetype=addn then
  1299. internalerror(200103291);
  1300. calcregisters(self,1,0,0);
  1301. end
  1302. { is there a 64 bit type ? }
  1303. else if (torddef(ld).typ in [s64bit,u64bit]) then
  1304. begin
  1305. result := first_add64bitint;
  1306. if assigned(result) then
  1307. exit;
  1308. calcregisters(self,2,0,0)
  1309. end
  1310. { is there a cardinal? }
  1311. else if (torddef(ld).typ=u32bit) then
  1312. begin
  1313. calcregisters(self,1,0,0);
  1314. { for unsigned mul we need an extra register }
  1315. if nodetype=muln then
  1316. inc(registers32);
  1317. end
  1318. { generic s32bit conversion }
  1319. else
  1320. calcregisters(self,1,0,0);
  1321. end
  1322. { left side a setdef, must be before string processing,
  1323. else array constructor can be seen as array of char (PFV) }
  1324. else if (ld.deftype=setdef) then
  1325. begin
  1326. if tsetdef(ld).settype=smallset then
  1327. begin
  1328. { are we adding set elements ? }
  1329. if right.nodetype=setelementn then
  1330. calcregisters(self,2,0,0)
  1331. else
  1332. calcregisters(self,1,0,0);
  1333. location.loc:=LOC_REGISTER;
  1334. end
  1335. else
  1336. begin
  1337. result := first_addset;
  1338. if assigned(result) then
  1339. exit;
  1340. calcregisters(self,0,0,0);
  1341. { here we call SET... }
  1342. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1343. location.loc:=LOC_MEM;
  1344. end;
  1345. end
  1346. { compare pchar by addresses like BP/Delphi }
  1347. else if is_pchar(ld) then
  1348. begin
  1349. location.loc:=LOC_REGISTER;
  1350. calcregisters(self,1,0,0);
  1351. end
  1352. { is one of the operands a string }
  1353. else if (ld.deftype=stringdef) then
  1354. begin
  1355. if is_widestring(ld) then
  1356. begin
  1357. { we use reference counted widestrings so no fast exit here }
  1358. procinfo^.no_fast_exit:=true;
  1359. { this is only for add, the comparisaion is handled later }
  1360. location.loc:=LOC_REGISTER;
  1361. end
  1362. else if is_ansistring(ld) then
  1363. begin
  1364. { we use ansistrings so no fast exit here }
  1365. procinfo^.no_fast_exit:=true;
  1366. { this is only for add, the comparisaion is handled later }
  1367. location.loc:=LOC_REGISTER;
  1368. end
  1369. else if is_longstring(ld) then
  1370. begin
  1371. { this is only for add, the comparisaion is handled later }
  1372. location.loc:=LOC_MEM;
  1373. end
  1374. else
  1375. begin
  1376. if canbeaddsstringcharoptnode(self) then
  1377. begin
  1378. hp := genaddsstringcharoptnode(self);
  1379. firstpass(hp);
  1380. pass_1 := hp;
  1381. exit;
  1382. end
  1383. else
  1384. begin
  1385. { Fix right to be shortstring }
  1386. if is_char(right.resulttype.def) then
  1387. begin
  1388. inserttypeconv(right,cshortstringtype);
  1389. firstpass(right);
  1390. end;
  1391. end;
  1392. if canbeaddsstringcsstringoptnode(self) then
  1393. begin
  1394. hp := genaddsstringcsstringoptnode(self);
  1395. firstpass(hp);
  1396. pass_1 := hp;
  1397. exit;
  1398. end;
  1399. end;
  1400. { otherwise, let addstring convert everything }
  1401. result := first_addstring;
  1402. exit;
  1403. end
  1404. { is one a real float ? }
  1405. else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
  1406. begin
  1407. calcregisters(self,0,1,0);
  1408. location.loc:=LOC_FPU;
  1409. end
  1410. { pointer comperation and subtraction }
  1411. else if (ld.deftype=pointerdef) then
  1412. begin
  1413. location.loc:=LOC_REGISTER;
  1414. calcregisters(self,1,0,0);
  1415. end
  1416. else if is_class_or_interface(ld) then
  1417. begin
  1418. location.loc:=LOC_REGISTER;
  1419. calcregisters(self,1,0,0);
  1420. end
  1421. else if (ld.deftype=classrefdef) then
  1422. begin
  1423. location.loc:=LOC_REGISTER;
  1424. calcregisters(self,1,0,0);
  1425. end
  1426. { support procvar=nil,procvar<>nil }
  1427. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1428. ((rd.deftype=procvardef) and (lt=niln)) then
  1429. begin
  1430. calcregisters(self,1,0,0);
  1431. location.loc:=LOC_REGISTER;
  1432. end
  1433. {$ifdef SUPPORT_MMX}
  1434. { mmx support, this must be before the zero based array
  1435. check }
  1436. else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
  1437. is_mmx_able_array(rd) then
  1438. begin
  1439. location.loc:=LOC_MMXREGISTER;
  1440. calcregisters(self,0,0,1);
  1441. end
  1442. {$endif SUPPORT_MMX}
  1443. else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
  1444. begin
  1445. location.loc:=LOC_REGISTER;
  1446. calcregisters(self,1,0,0);
  1447. end
  1448. else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then
  1449. begin
  1450. calcregisters(self,1,0,0);
  1451. location.loc:=LOC_REGISTER;
  1452. end
  1453. else if (ld.deftype=enumdef) then
  1454. begin
  1455. calcregisters(self,1,0,0);
  1456. end
  1457. {$ifdef SUPPORT_MMX}
  1458. else if (cs_mmx in aktlocalswitches) and
  1459. is_mmx_able_array(ld) and
  1460. is_mmx_able_array(rd) then
  1461. begin
  1462. location.loc:=LOC_MMXREGISTER;
  1463. calcregisters(self,0,0,1);
  1464. end
  1465. {$endif SUPPORT_MMX}
  1466. { the general solution is to convert to 32 bit int }
  1467. else
  1468. begin
  1469. calcregisters(self,1,0,0);
  1470. location.loc:=LOC_REGISTER;
  1471. end;
  1472. case nodetype of
  1473. ltn,lten,gtn,gten,equaln,unequaln:
  1474. begin
  1475. if is_64bitint(left.resulttype.def) then
  1476. location.loc:=LOC_JUMP
  1477. else
  1478. location.loc:=LOC_FLAGS;
  1479. end;
  1480. xorn:
  1481. begin
  1482. location.loc:=LOC_REGISTER;
  1483. end;
  1484. end;
  1485. end;
  1486. begin
  1487. caddnode:=taddnode;
  1488. end.
  1489. {
  1490. $Log$
  1491. Revision 1.39 2001-09-05 15:22:09 jonas
  1492. * made multiplying, dividing and mod'ing of int64 and qword processor
  1493. independent with compilerprocs (+ small optimizations by using shift/and
  1494. where possible)
  1495. Revision 1.38 2001/09/04 11:38:54 jonas
  1496. + searchsystype() and searchsystype() functions in symtable
  1497. * changed ninl and nadd to use these functions
  1498. * i386 set comparison functions now return their results in al instead
  1499. of in the flags so that they can be sued as compilerprocs
  1500. - removed all processor specific code from n386add.pas that has to do
  1501. with set handling, it's now all done in nadd.pas
  1502. * fixed fpc_set_contains_sets in genset.inc
  1503. * fpc_set_in_byte is now coded inline in n386set.pas and doesn't use a
  1504. helper anymore
  1505. * some small fixes in compproc.inc/set.inc regarding the declaration of
  1506. internal helper types (fpc_small_set and fpc_normal_set)
  1507. Revision 1.37 2001/09/03 13:27:42 jonas
  1508. * compilerproc implementation of set addition/substraction/...
  1509. * changed the declaration of some set helpers somewhat to accomodate the
  1510. above change
  1511. * i386 still uses the old code for comparisons of sets, because its
  1512. helpers return the results in the flags
  1513. * dummy tc_normal_2_small_set type conversion because I need the original
  1514. resulttype of the set add nodes
  1515. NOTE: you have to start a cycle with 1.0.5!
  1516. Revision 1.36 2001/09/02 21:12:06 peter
  1517. * move class of definitions into type section for delphi
  1518. Revision 1.35 2001/08/31 15:42:15 jonas
  1519. * added missing type conversion from small to normal sets
  1520. Revision 1.34 2001/08/30 15:43:14 jonas
  1521. * converted adding/comparing of strings to compileproc. Note that due
  1522. to the way the shortstring helpers for i386 are written, they are
  1523. still handled by the old code (reason: fpc_shortstr_compare returns
  1524. results in the flags instead of in eax and fpc_shortstr_concat
  1525. has wierd parameter conventions). The compilerproc stuff should work
  1526. fine with the generic implementations though.
  1527. * removed some nested comments warnings
  1528. Revision 1.33 2001/08/26 13:36:38 florian
  1529. * some cg reorganisation
  1530. * some PPC updates
  1531. Revision 1.32 2001/08/06 21:40:46 peter
  1532. * funcret moved from tprocinfo to tprocdef
  1533. Revision 1.31 2001/07/08 21:00:14 peter
  1534. * various widestring updates, it works now mostly without charset
  1535. mapping supported
  1536. Revision 1.30 2001/06/04 21:41:26 peter
  1537. * readded generic conversion to s32bit that i removed yesterday. It
  1538. is still used for error recovery, added a small note about that
  1539. Revision 1.29 2001/06/04 18:13:53 peter
  1540. * Support kylix hack of having enum+integer in a enum declaration.
  1541. Revision 1.28 2001/05/27 14:30:55 florian
  1542. + some widestring stuff added
  1543. Revision 1.27 2001/05/19 21:11:50 peter
  1544. * first check for overloaded operator before doing inserting any
  1545. typeconvs
  1546. Revision 1.26 2001/05/19 12:53:52 peter
  1547. * check set types when doing constant set evaluation
  1548. Revision 1.25 2001/04/13 01:22:08 peter
  1549. * symtable change to classes
  1550. * range check generation and errors fixed, make cycle DEBUG=1 works
  1551. * memory leaks fixed
  1552. Revision 1.24 2001/04/04 22:42:39 peter
  1553. * move constant folding into det_resulttype
  1554. Revision 1.23 2001/04/02 21:20:30 peter
  1555. * resulttype rewrite
  1556. Revision 1.22 2001/02/04 11:12:17 jonas
  1557. * fixed web bug 1377 & const pointer arithmtic
  1558. Revision 1.21 2001/01/14 22:13:13 peter
  1559. * constant calculation fixed. The type of the new constant is now
  1560. defined after the calculation is done. This should remove a lot
  1561. of wrong warnings (and errors with -Cr).
  1562. Revision 1.20 2000/12/31 11:14:10 jonas
  1563. + implemented/fixed docompare() mathods for all nodes (not tested)
  1564. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1565. and constant strings/chars together
  1566. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1567. when adding
  1568. Revision 1.19 2000/12/16 15:55:32 jonas
  1569. + warning when there is a chance to get a range check error because of
  1570. automatic type conversion to u32bit
  1571. * arithmetic operations with a cardinal and a signed operand are carried
  1572. out in 64bit when range checking is on ("merged" from fixes branch)
  1573. Revision 1.18 2000/11/29 00:30:31 florian
  1574. * unused units removed from uses clause
  1575. * some changes for widestrings
  1576. Revision 1.17 2000/11/20 15:30:42 jonas
  1577. * changed types of values used for constant expression evaluation to
  1578. tconstexprint
  1579. Revision 1.16 2000/11/13 11:30:55 florian
  1580. * some bugs with interfaces and NIL fixed
  1581. Revision 1.15 2000/11/04 14:25:20 florian
  1582. + merged Attila's changes for interfaces, not tested yet
  1583. Revision 1.14 2000/10/31 22:02:47 peter
  1584. * symtable splitted, no real code changes
  1585. Revision 1.13 2000/10/14 10:14:50 peter
  1586. * moehrendorf oct 2000 rewrite
  1587. Revision 1.12 2000/10/01 19:48:23 peter
  1588. * lot of compile updates for cg11
  1589. Revision 1.11 2000/09/30 16:08:45 peter
  1590. * more cg11 updates
  1591. Revision 1.10 2000/09/28 19:49:52 florian
  1592. *** empty log message ***
  1593. Revision 1.9 2000/09/27 21:33:22 florian
  1594. * finally nadd.pas compiles
  1595. Revision 1.8 2000/09/27 20:25:44 florian
  1596. * more stuff fixed
  1597. Revision 1.7 2000/09/27 18:14:31 florian
  1598. * fixed a lot of syntax errors in the n*.pas stuff
  1599. Revision 1.6 2000/09/24 15:06:19 peter
  1600. * use defines.inc
  1601. Revision 1.5 2000/09/22 22:42:52 florian
  1602. * more fixes
  1603. Revision 1.4 2000/09/21 12:22:42 jonas
  1604. * put piece of code between -dnewoptimizations2 since it wasn't
  1605. necessary otherwise
  1606. + support for full boolean evaluation (from tcadd)
  1607. Revision 1.3 2000/09/20 21:50:59 florian
  1608. * updated
  1609. Revision 1.2 2000/08/29 08:24:45 jonas
  1610. * some modifications to -dcardinalmulfix code
  1611. Revision 1.1 2000/08/26 12:24:20 florian
  1612. * initial release
  1613. }