nadd.pas 70 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796
  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,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. left.toggleflag(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 if size adjusting is needed, only for left
  415. to right as the other way is checked in the typeconv }
  416. if (tsetdef(right.resulttype.def).settype=smallset) and
  417. (tsetdef(left.resulttype.def).settype<>smallset) then
  418. tsetdef(right.resulttype.def).changesettype(normset);
  419. { check base types }
  420. inserttypeconv(left,right.resulttype);
  421. if codegenerror then
  422. begin
  423. { recover by only returning the left part }
  424. result:=left;
  425. left:=nil;
  426. exit;
  427. end;
  428. new(resultset);
  429. case nodetype of
  430. addn :
  431. begin
  432. for i:=0 to 31 do
  433. resultset^[i]:=tsetconstnode(right).value_set^[i] or tsetconstnode(left).value_set^[i];
  434. t:=csetconstnode.create(resultset,left.resulttype);
  435. end;
  436. muln :
  437. begin
  438. for i:=0 to 31 do
  439. resultset^[i]:=tsetconstnode(right).value_set^[i] and tsetconstnode(left).value_set^[i];
  440. t:=csetconstnode.create(resultset,left.resulttype);
  441. end;
  442. subn :
  443. begin
  444. for i:=0 to 31 do
  445. resultset^[i]:=tsetconstnode(left).value_set^[i] and not(tsetconstnode(right).value_set^[i]);
  446. t:=csetconstnode.create(resultset,left.resulttype);
  447. end;
  448. symdifn :
  449. begin
  450. for i:=0 to 31 do
  451. resultset^[i]:=tsetconstnode(left).value_set^[i] xor tsetconstnode(right).value_set^[i];
  452. t:=csetconstnode.create(resultset,left.resulttype);
  453. end;
  454. unequaln :
  455. begin
  456. b:=true;
  457. for i:=0 to 31 do
  458. if tsetconstnode(right).value_set^[i]=tsetconstnode(left).value_set^[i] then
  459. begin
  460. b:=false;
  461. break;
  462. end;
  463. t:=cordconstnode.create(ord(b),booltype);
  464. end;
  465. equaln :
  466. begin
  467. b:=true;
  468. for i:=0 to 31 do
  469. if tsetconstnode(right).value_set^[i]<>tsetconstnode(left).value_set^[i] then
  470. begin
  471. b:=false;
  472. break;
  473. end;
  474. t:=cordconstnode.create(ord(b),booltype);
  475. end;
  476. lten :
  477. begin
  478. b := true;
  479. For i := 0 to 31 Do
  480. If (tsetconstnode(right).value_set^[i] And tsetconstnode(left).value_set^[i]) <>
  481. tsetconstnode(left).value_set^[i] Then
  482. Begin
  483. b := false;
  484. Break
  485. End;
  486. t := cordconstnode.create(ord(b),booltype);
  487. End;
  488. gten :
  489. Begin
  490. b := true;
  491. For i := 0 to 31 Do
  492. If (tsetconstnode(left).value_set^[i] And tsetconstnode(right).value_set^[i]) <>
  493. tsetconstnode(right).value_set^[i] Then
  494. Begin
  495. b := false;
  496. Break
  497. End;
  498. t := cordconstnode.create(ord(b),booltype);
  499. End;
  500. end;
  501. dispose(resultset);
  502. result:=t;
  503. exit;
  504. end;
  505. { but an int/int gives real/real! }
  506. if nodetype=slashn then
  507. begin
  508. CGMessage(type_h_use_div_for_int);
  509. inserttypeconv(right,pbestrealtype^);
  510. inserttypeconv(left,pbestrealtype^);
  511. end
  512. { if both are orddefs then check sub types }
  513. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  514. begin
  515. { 2 booleans? Make them equal to the largest boolean }
  516. if is_boolean(ld) and is_boolean(rd) then
  517. begin
  518. if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then
  519. begin
  520. right:=ctypeconvnode.create(right,left.resulttype);
  521. ttypeconvnode(right).convtype:=tc_bool_2_int;
  522. right.toggleflag(nf_explizit);
  523. resulttypepass(right);
  524. end
  525. else if torddef(left.resulttype.def).size<torddef(right.resulttype.def).size then
  526. begin
  527. left:=ctypeconvnode.create(left,right.resulttype);
  528. ttypeconvnode(left).convtype:=tc_bool_2_int;
  529. left.toggleflag(nf_explizit);
  530. resulttypepass(left);
  531. end;
  532. case nodetype of
  533. xorn,
  534. ltn,
  535. lten,
  536. gtn,
  537. gten,
  538. andn,
  539. orn:
  540. begin
  541. end;
  542. unequaln,
  543. equaln:
  544. begin
  545. if not(cs_full_boolean_eval in aktlocalswitches) then
  546. begin
  547. { Remove any compares with constants }
  548. if (left.nodetype=ordconstn) then
  549. begin
  550. hp:=right;
  551. b:=(tordconstnode(left).value<>0);
  552. ot:=nodetype;
  553. left.free;
  554. left:=nil;
  555. right:=nil;
  556. if (not(b) and (ot=equaln)) or
  557. (b and (ot=unequaln)) then
  558. begin
  559. hp:=cnotnode.create(hp);
  560. end;
  561. result:=hp;
  562. exit;
  563. end;
  564. if (right.nodetype=ordconstn) then
  565. begin
  566. hp:=left;
  567. b:=(tordconstnode(right).value<>0);
  568. ot:=nodetype;
  569. right.free;
  570. right:=nil;
  571. left:=nil;
  572. if (not(b) and (ot=equaln)) or
  573. (b and (ot=unequaln)) then
  574. begin
  575. hp:=cnotnode.create(hp);
  576. end;
  577. result:=hp;
  578. exit;
  579. end;
  580. end;
  581. end;
  582. else
  583. CGMessage(type_e_mismatch);
  584. end;
  585. end
  586. { Both are chars? }
  587. else if is_char(rd) and is_char(ld) then
  588. begin
  589. if nodetype=addn then
  590. begin
  591. resulttype:=cshortstringtype;
  592. if not(is_constcharnode(left) and is_constcharnode(right)) then
  593. begin
  594. inserttypeconv(left,cshortstringtype);
  595. hp := genaddsstringcharoptnode(self);
  596. result := hp;
  597. exit;
  598. end;
  599. end;
  600. end
  601. { is there a signed 64 bit type ? }
  602. else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
  603. begin
  604. if (torddef(ld).typ<>s64bit) then
  605. inserttypeconv(left,cs64bittype);
  606. if (torddef(rd).typ<>s64bit) then
  607. inserttypeconv(right,cs64bittype);
  608. end
  609. { is there a unsigned 64 bit type ? }
  610. else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then
  611. begin
  612. if (torddef(ld).typ<>u64bit) then
  613. inserttypeconv(left,cu64bittype);
  614. if (torddef(rd).typ<>u64bit) then
  615. inserttypeconv(right,cu64bittype);
  616. end
  617. { is there a cardinal? }
  618. else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then
  619. begin
  620. if is_signed(ld) and
  621. { then rd = u32bit }
  622. { convert positive constants to u32bit }
  623. not(is_constintnode(left) and
  624. (tordconstnode(left).value >= 0)) and
  625. { range/overflow checking on mixed signed/cardinal expressions }
  626. { is only possible if you convert everything to 64bit (JM) }
  627. ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and
  628. (nodetype in [addn,subn,muln])) then
  629. begin
  630. { perform the operation in 64bit }
  631. CGMessage(type_w_mixed_signed_unsigned);
  632. inserttypeconv(left,cs64bittype);
  633. inserttypeconv(right,cs64bittype);
  634. end
  635. else
  636. begin
  637. if is_signed(ld) and
  638. not(is_constintnode(left) and
  639. (tordconstnode(left).value >= 0)) and
  640. (cs_check_range in aktlocalswitches) then
  641. CGMessage(type_w_mixed_signed_unsigned2);
  642. inserttypeconv(left,u32bittype);
  643. if is_signed(rd) and
  644. { then ld = u32bit }
  645. { convert positive constants to u32bit }
  646. not(is_constintnode(right) and
  647. (tordconstnode(right).value >= 0)) and
  648. ((aktlocalswitches * [cs_check_overflow,cs_check_range] <> []) and
  649. (nodetype in [addn,subn,muln])) then
  650. begin
  651. { perform the operation in 64bit }
  652. CGMessage(type_w_mixed_signed_unsigned);
  653. inserttypeconv(left,cs64bittype);
  654. inserttypeconv(right,cs64bittype);
  655. end
  656. else
  657. begin
  658. if is_signed(rd) and
  659. not(is_constintnode(right) and
  660. (tordconstnode(right).value >= 0)) and
  661. (cs_check_range in aktlocalswitches) then
  662. CGMessage(type_w_mixed_signed_unsigned2);
  663. inserttypeconv(right,u32bittype);
  664. end;
  665. end;
  666. end
  667. { generic ord conversion is s32bit }
  668. else
  669. begin
  670. inserttypeconv(right,s32bittype);
  671. inserttypeconv(left,s32bittype);
  672. end;
  673. end
  674. { if both are floatdefs, conversion is already done before constant folding }
  675. else if (ld.deftype=floatdef) then
  676. begin
  677. { already converted }
  678. end
  679. { left side a setdef, must be before string processing,
  680. else array constructor can be seen as array of char (PFV) }
  681. else if (ld.deftype=setdef) then
  682. begin
  683. { trying to add a set element? }
  684. if (nodetype=addn) and (rd.deftype<>setdef) then
  685. begin
  686. if (rt=setelementn) then
  687. begin
  688. if not(is_equal(tsetdef(ld).elementtype.def,rd)) then
  689. CGMessage(type_e_set_element_are_not_comp);
  690. end
  691. else
  692. CGMessage(type_e_mismatch)
  693. end
  694. else
  695. begin
  696. if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
  697. CGMessage(type_e_set_operation_unknown);
  698. { right def must be a also be set }
  699. if (rd.deftype<>setdef) or not(is_equal(rd,ld)) then
  700. CGMessage(type_e_set_element_are_not_comp);
  701. end;
  702. { ranges require normsets }
  703. if (tsetdef(ld).settype=smallset) and
  704. (rt=setelementn) and
  705. assigned(tsetelementnode(right).right) then
  706. begin
  707. { generate a temporary normset def, it'll be destroyed
  708. when the symtable is unloaded }
  709. htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
  710. inserttypeconv(left,htype);
  711. end;
  712. { if the right side is also a setdef then the settype must
  713. be the same as the left setdef }
  714. if (rd.deftype=setdef) and
  715. (tsetdef(ld).settype<>tsetdef(rd).settype) then
  716. inserttypeconv(right,left.resulttype);
  717. end
  718. { compare pchar to char arrays by addresses like BP/Delphi }
  719. else if (is_pchar(ld) and is_chararray(rd)) or
  720. (is_pchar(rd) and is_chararray(ld)) then
  721. begin
  722. if is_chararray(rd) then
  723. inserttypeconv(right,left.resulttype)
  724. else
  725. inserttypeconv(left,right.resulttype);
  726. end
  727. { is one of the operands a string?,
  728. chararrays are also handled as strings (after conversion), also take
  729. care of chararray+chararray and chararray+char }
  730. else if (rd.deftype=stringdef) or (ld.deftype=stringdef) or
  731. ((is_chararray(rd) or is_char(rd)) and
  732. (is_chararray(ld) or is_char(ld))) then
  733. begin
  734. if is_widestring(rd) or is_widestring(ld) then
  735. begin
  736. if not(is_widestring(rd)) then
  737. inserttypeconv(right,cwidestringtype);
  738. if not(is_widestring(ld)) then
  739. inserttypeconv(left,cwidestringtype);
  740. end
  741. else if is_ansistring(rd) or is_ansistring(ld) then
  742. begin
  743. if not(is_ansistring(rd)) then
  744. inserttypeconv(right,cansistringtype);
  745. if not(is_ansistring(ld)) then
  746. inserttypeconv(left,cansistringtype);
  747. end
  748. else if is_longstring(rd) or is_longstring(ld) then
  749. begin
  750. if not(is_longstring(rd)) then
  751. inserttypeconv(right,clongstringtype);
  752. if not(is_longstring(ld)) then
  753. inserttypeconv(left,clongstringtype);
  754. location.loc:=LOC_CREFERENCE;
  755. end
  756. else
  757. begin
  758. if not(is_shortstring(ld)) then
  759. inserttypeconv(left,cshortstringtype);
  760. { don't convert char, that can be handled by the optimized node }
  761. if not(is_shortstring(rd) or is_char(rd)) then
  762. inserttypeconv(right,cshortstringtype);
  763. end;
  764. end
  765. { pointer comparision and subtraction }
  766. else if (rd.deftype=pointerdef) and (ld.deftype=pointerdef) then
  767. begin
  768. case nodetype of
  769. equaln,unequaln :
  770. begin
  771. if is_voidpointer(right.resulttype.def) then
  772. inserttypeconv(right,left.resulttype)
  773. else if is_voidpointer(left.resulttype.def) then
  774. inserttypeconv(left,right.resulttype)
  775. else if not(is_equal(ld,rd)) then
  776. CGMessage(type_e_mismatch);
  777. end;
  778. ltn,lten,gtn,gten:
  779. begin
  780. if (cs_extsyntax in aktmoduleswitches) then
  781. begin
  782. if is_voidpointer(right.resulttype.def) then
  783. inserttypeconv(right,left.resulttype)
  784. else if is_voidpointer(left.resulttype.def) then
  785. inserttypeconv(left,right.resulttype)
  786. else if not(is_equal(ld,rd)) then
  787. CGMessage(type_e_mismatch);
  788. end
  789. else
  790. CGMessage(type_e_mismatch);
  791. end;
  792. subn:
  793. begin
  794. if (cs_extsyntax in aktmoduleswitches) then
  795. begin
  796. if is_voidpointer(right.resulttype.def) then
  797. inserttypeconv(right,left.resulttype)
  798. else if is_voidpointer(left.resulttype.def) then
  799. inserttypeconv(left,right.resulttype)
  800. else if not(is_equal(ld,rd)) then
  801. CGMessage(type_e_mismatch);
  802. end
  803. else
  804. CGMessage(type_e_mismatch);
  805. resulttype:=s32bittype;
  806. exit;
  807. end;
  808. addn:
  809. begin
  810. if (cs_extsyntax in aktmoduleswitches) then
  811. begin
  812. if is_voidpointer(right.resulttype.def) then
  813. inserttypeconv(right,left.resulttype)
  814. else if is_voidpointer(left.resulttype.def) then
  815. inserttypeconv(left,right.resulttype)
  816. else if not(is_equal(ld,rd)) then
  817. CGMessage(type_e_mismatch);
  818. end
  819. else
  820. CGMessage(type_e_mismatch);
  821. resulttype:=s32bittype;
  822. exit;
  823. end;
  824. else
  825. CGMessage(type_e_mismatch);
  826. end;
  827. end
  828. { class or interface equation }
  829. else if is_class_or_interface(rd) or is_class_or_interface(ld) then
  830. begin
  831. if is_class_or_interface(rd) and is_class_or_interface(ld) then
  832. begin
  833. if tobjectdef(rd).is_related(tobjectdef(ld)) then
  834. inserttypeconv(right,left.resulttype)
  835. else
  836. inserttypeconv(left,right.resulttype);
  837. end
  838. else if is_class_or_interface(rd) then
  839. inserttypeconv(left,right.resulttype)
  840. else
  841. inserttypeconv(right,left.resulttype);
  842. if not(nodetype in [equaln,unequaln]) then
  843. CGMessage(type_e_mismatch);
  844. end
  845. else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
  846. begin
  847. if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
  848. tobjectdef(tclassrefdef(ld).pointertype.def)) then
  849. inserttypeconv(right,left.resulttype)
  850. else
  851. inserttypeconv(left,right.resulttype);
  852. if not(nodetype in [equaln,unequaln]) then
  853. CGMessage(type_e_mismatch);
  854. end
  855. { allows comperasion with nil pointer }
  856. else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
  857. begin
  858. inserttypeconv(left,right.resulttype);
  859. if not(nodetype in [equaln,unequaln]) then
  860. CGMessage(type_e_mismatch);
  861. end
  862. else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
  863. begin
  864. inserttypeconv(right,left.resulttype);
  865. if not(nodetype in [equaln,unequaln]) then
  866. CGMessage(type_e_mismatch);
  867. end
  868. { support procvar=nil,procvar<>nil }
  869. else if ((ld.deftype=procvardef) and (rt=niln)) or
  870. ((rd.deftype=procvardef) and (lt=niln)) then
  871. begin
  872. if not(nodetype in [equaln,unequaln]) then
  873. CGMessage(type_e_mismatch);
  874. end
  875. {$ifdef SUPPORT_MMX}
  876. { mmx support, this must be before the zero based array
  877. check }
  878. else if (cs_mmx in aktlocalswitches) and
  879. is_mmx_able_array(ld) and
  880. is_mmx_able_array(rd) and
  881. is_equal(ld,rd) then
  882. begin
  883. case nodetype of
  884. addn,subn,xorn,orn,andn:
  885. ;
  886. { mul is a little bit restricted }
  887. muln:
  888. if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
  889. CGMessage(type_e_mismatch);
  890. else
  891. CGMessage(type_e_mismatch);
  892. end;
  893. end
  894. {$endif SUPPORT_MMX}
  895. { this is a little bit dangerous, also the left type }
  896. { pointer to should be checked! This broke the mmx support }
  897. else if (rd.deftype=pointerdef) or is_zero_based_array(rd) then
  898. begin
  899. if is_zero_based_array(rd) then
  900. begin
  901. resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
  902. inserttypeconv(right,resulttype);
  903. end;
  904. inserttypeconv(left,s32bittype);
  905. if nodetype=addn then
  906. begin
  907. if not(cs_extsyntax in aktmoduleswitches) or
  908. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  909. CGMessage(type_e_mismatch);
  910. if (rd.deftype=pointerdef) and
  911. (tpointerdef(rd).pointertype.def.size>1) then
  912. left:=caddnode.create(muln,left,cordconstnode.create(tpointerdef(rd).pointertype.def.size,s32bittype));
  913. end
  914. else
  915. CGMessage(type_e_mismatch);
  916. end
  917. else if (ld.deftype=pointerdef) or is_zero_based_array(ld) then
  918. begin
  919. if is_zero_based_array(ld) then
  920. begin
  921. resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
  922. inserttypeconv(left,resulttype);
  923. end;
  924. inserttypeconv(right,s32bittype);
  925. if nodetype in [addn,subn] then
  926. begin
  927. if not(cs_extsyntax in aktmoduleswitches) or
  928. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  929. CGMessage(type_e_mismatch);
  930. if (ld.deftype=pointerdef) and
  931. (tpointerdef(ld).pointertype.def.size>1) then
  932. right:=caddnode.create(muln,right,cordconstnode.create(tpointerdef(ld).pointertype.def.size,s32bittype));
  933. end
  934. else
  935. CGMessage(type_e_mismatch);
  936. end
  937. else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then
  938. begin
  939. if not (nodetype in [equaln,unequaln]) then
  940. CGMessage(type_e_mismatch);
  941. end
  942. { enums }
  943. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  944. begin
  945. if not(is_equal(ld,rd)) then
  946. inserttypeconv(right,left.resulttype);
  947. if not(nodetype in [equaln,unequaln,ltn,lten,gtn,gten]) then
  948. CGMessage(type_e_mismatch);
  949. end
  950. { generic conversion, this is for error recovery }
  951. else
  952. begin
  953. inserttypeconv(left,s32bittype);
  954. inserttypeconv(right,s32bittype);
  955. end;
  956. { set resulttype if not already done }
  957. if not assigned(resulttype.def) then
  958. begin
  959. case nodetype of
  960. ltn,lten,gtn,gten,equaln,unequaln :
  961. resulttype:=booltype;
  962. slashn :
  963. resulttype:=pbestrealtype^;
  964. addn:
  965. begin
  966. { for strings, return is always a 255 char string }
  967. if is_shortstring(left.resulttype.def) then
  968. resulttype:=cshortstringtype
  969. else
  970. resulttype:=left.resulttype;
  971. end;
  972. else
  973. resulttype:=left.resulttype;
  974. end;
  975. end;
  976. end;
  977. function taddnode.first_addstring: tnode;
  978. var
  979. p: tnode;
  980. begin
  981. { when we get here, we are sure that both the left and the right }
  982. { node are both strings of the same stringtype (JM) }
  983. case nodetype of
  984. addn:
  985. begin
  986. { note: if you implemented an fpc_shortstr_concat similar to the }
  987. { one in i386.inc, you have to override first_addstring like in }
  988. { ti386addnode.first_string and implement the shortstring concat }
  989. { manually! The generic routine is different from the i386 one (JM) }
  990. { create the call to the concat routine both strings as arguments }
  991. result := ccallnode.createintern('fpc_'+
  992. lower(tstringdef(resulttype.def).stringtypname)+'_concat',
  993. ccallparanode.create(right,ccallparanode.create(left,nil)));
  994. { we reused the arguments }
  995. left := nil;
  996. right := nil;
  997. firstpass(result);
  998. end;
  999. ltn,lten,gtn,gten,equaln,unequaln :
  1000. begin
  1001. { generate better code for s='' and s<>'' }
  1002. if (nodetype in [equaln,unequaln]) and
  1003. (((left.nodetype=stringconstn) and (str_length(left)=0)) or
  1004. ((right.nodetype=stringconstn) and (str_length(right)=0))) then
  1005. begin
  1006. { switch so that the constant is always on the right }
  1007. if left.nodetype = stringconstn then
  1008. begin
  1009. p := left;
  1010. left := right;
  1011. right := p;
  1012. end;
  1013. if is_shortstring(left.resulttype.def) then
  1014. { compare the length with 0 }
  1015. result := caddnode.create(nodetype,
  1016. cinlinenode.create(in_length_x,false,left),
  1017. cordconstnode.create(0,s32bittype))
  1018. else
  1019. begin
  1020. { compare the pointer with nil (for ansistrings etc), }
  1021. { faster than getting the length (JM) }
  1022. result:= caddnode.create(nodetype,
  1023. ctypeconvnode.create(left,voidpointertype),
  1024. cpointerconstnode.create(0,voidpointertype));
  1025. taddnode(result).left.toggleflag(nf_explizit);
  1026. end;
  1027. { left is reused }
  1028. left := nil;
  1029. { right isn't }
  1030. right.free;
  1031. right := nil;
  1032. firstpass(result);
  1033. exit;
  1034. end;
  1035. { no string constant -> call compare routine }
  1036. result := ccallnode.createintern('fpc_'+
  1037. lower(tstringdef(left.resulttype.def).stringtypname)+'_compare',
  1038. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1039. { and compare its result with 0 according to the original operator }
  1040. result := caddnode.create(nodetype,result,
  1041. cordconstnode.create(0,s32bittype));
  1042. left := nil;
  1043. right := nil;
  1044. firstpass(result);
  1045. end;
  1046. end;
  1047. end;
  1048. function taddnode.first_addset: tnode;
  1049. var
  1050. procname: string[31];
  1051. tempn: tnode;
  1052. paras: tcallparanode;
  1053. srsym: ttypesym;
  1054. begin
  1055. { get the sym that represents the fpc_normal_set type }
  1056. if not searchsystype('FPC_NORMAL_SET',srsym) then
  1057. internalerror(200108313);
  1058. case nodetype of
  1059. equaln,unequaln,lten,gten:
  1060. begin
  1061. case nodetype of
  1062. equaln,unequaln:
  1063. procname := 'fpc_set_comp_sets';
  1064. lten,gten:
  1065. begin
  1066. procname := 'fpc_set_contains_sets';
  1067. { (left >= right) = (right <= left) }
  1068. if nodetype = gten then
  1069. begin
  1070. tempn := left;
  1071. left := right;
  1072. right := tempn;
  1073. end;
  1074. end;
  1075. end;
  1076. { convert the arguments (explicitely) to fpc_normal_set's }
  1077. left := ctypeconvnode.create(left,srsym.restype);
  1078. left.toggleflag(nf_explizit);
  1079. right := ctypeconvnode.create(right,srsym.restype);
  1080. right.toggleflag(nf_explizit);
  1081. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1082. ccallparanode.create(left,nil)));
  1083. { left and right are reused as parameters }
  1084. left := nil;
  1085. right := nil;
  1086. { for an unequaln, we have to negate the result of comp_sets }
  1087. if nodetype = unequaln then
  1088. result := cnotnode.create(result);
  1089. end;
  1090. addn:
  1091. begin
  1092. { optimize first loading of a set }
  1093. if (right.nodetype=setelementn) and
  1094. not(assigned(tsetelementnode(right).right)) and
  1095. is_emptyset(left) then
  1096. begin
  1097. { type cast the value to pass as argument to a byte, }
  1098. { since that's what the helper expects }
  1099. tsetelementnode(right).left :=
  1100. ctypeconvnode.create(tsetelementnode(right).left,u8bittype);
  1101. tsetelementnode(right).left.toggleflag(nf_explizit);
  1102. { set the resulttype to the actual one (otherwise it's }
  1103. { "fpc_normal_set") }
  1104. result := ccallnode.createinternres('fpc_set_create_element',
  1105. ccallparanode.create(tsetelementnode(right).left,nil),
  1106. resulttype);
  1107. { reused }
  1108. tsetelementnode(right).left := nil;
  1109. end
  1110. else
  1111. begin
  1112. if right.nodetype=setelementn then
  1113. begin
  1114. { convert the arguments to bytes, since that's what }
  1115. { the helper expects }
  1116. tsetelementnode(right).left :=
  1117. ctypeconvnode.create(tsetelementnode(right).left,
  1118. u8bittype);
  1119. tsetelementnode(right).left.toggleflag(nf_explizit);
  1120. { convert the original set (explicitely) to an }
  1121. { fpc_normal_set so we can pass it to the helper }
  1122. left := ctypeconvnode.create(left,srsym.restype);
  1123. left.toggleflag(nf_explizit);
  1124. { add a range or a single element? }
  1125. if assigned(tsetelementnode(right).right) then
  1126. begin
  1127. tsetelementnode(right).right :=
  1128. ctypeconvnode.create(tsetelementnode(right).right,
  1129. u8bittype);
  1130. tsetelementnode(right).right.toggleflag(nf_explizit);
  1131. { create the call }
  1132. result := ccallnode.createinternres('fpc_set_set_range',
  1133. ccallparanode.create(tsetelementnode(right).right,
  1134. ccallparanode.create(tsetelementnode(right).left,
  1135. ccallparanode.create(left,nil))),resulttype);
  1136. end
  1137. else
  1138. begin
  1139. result := ccallnode.createinternres('fpc_set_set_byte',
  1140. ccallparanode.create(tsetelementnode(right).left,
  1141. ccallparanode.create(left,nil)),resulttype);
  1142. end;
  1143. { remove reused parts from original node }
  1144. tsetelementnode(right).right := nil;
  1145. tsetelementnode(right).left := nil;
  1146. left := nil;
  1147. end
  1148. else
  1149. begin
  1150. { add two sets }
  1151. { convert the sets to fpc_normal_set's }
  1152. left := ctypeconvnode.create(left,srsym.restype);
  1153. left.toggleflag(nf_explizit);
  1154. right := ctypeconvnode.create(right,srsym.restype);
  1155. right.toggleflag(nf_explizit);
  1156. result := ccallnode.createinternres('fpc_set_add_sets',
  1157. ccallparanode.create(right,
  1158. ccallparanode.create(left,nil)),resulttype);
  1159. { remove reused parts from original node }
  1160. left := nil;
  1161. right := nil;
  1162. end;
  1163. end
  1164. end;
  1165. subn,symdifn,muln:
  1166. begin
  1167. { convert the sets to fpc_normal_set's }
  1168. left := ctypeconvnode.create(left,srsym.restype);
  1169. left.toggleflag(nf_explizit);
  1170. right := ctypeconvnode.create(right,srsym.restype);
  1171. right.toggleflag(nf_explizit);
  1172. paras := ccallparanode.create(right,
  1173. ccallparanode.create(left,nil));
  1174. case nodetype of
  1175. subn:
  1176. result := ccallnode.createinternres('fpc_set_sub_sets',
  1177. paras,resulttype);
  1178. symdifn:
  1179. result := ccallnode.createinternres('fpc_set_symdif_sets',
  1180. paras,resulttype);
  1181. muln:
  1182. result := ccallnode.createinternres('fpc_set_mul_sets',
  1183. paras,resulttype);
  1184. end;
  1185. { remove reused parts from original node }
  1186. left := nil;
  1187. right := nil;
  1188. end;
  1189. else
  1190. internalerror(200108311);
  1191. end;
  1192. firstpass(result);
  1193. end;
  1194. function taddnode.first_add64bitint: tnode;
  1195. var
  1196. procname: string[31];
  1197. temp: tnode;
  1198. power: longint;
  1199. begin
  1200. result := nil;
  1201. { create helper calls mul }
  1202. if nodetype <> muln then
  1203. exit;
  1204. { make sure that if there is a constant, that it's on the right }
  1205. if left.nodetype = ordconstn then
  1206. begin
  1207. temp := right;
  1208. right := left;
  1209. left := temp;
  1210. end;
  1211. { can we use a shift instead of a mul? }
  1212. if (right.nodetype = ordconstn) and
  1213. ispowerof2(tordconstnode(right).value,power) then
  1214. begin
  1215. tordconstnode(right).value := power;
  1216. result := cshlshrnode.create(shln,left,right);
  1217. { left and right are reused }
  1218. left := nil;
  1219. right := nil;
  1220. { return firstpassed new node }
  1221. firstpass(result);
  1222. exit;
  1223. end;
  1224. { otherwise, create the parameters for the helper }
  1225. right := ccallparanode.create(
  1226. cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype),
  1227. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1228. left := nil;
  1229. if torddef(resulttype.def).typ = s64bit then
  1230. procname := 'fpc_mul_int64'
  1231. else
  1232. procname := 'fpc_mul_qword';
  1233. result := ccallnode.createintern(procname,right);
  1234. right := nil;
  1235. firstpass(result);
  1236. end;
  1237. function taddnode.pass_1 : tnode;
  1238. var
  1239. hp : tnode;
  1240. lt,rt : tnodetype;
  1241. rd,ld : tdef;
  1242. begin
  1243. result:=nil;
  1244. { first do the two subtrees }
  1245. firstpass(left);
  1246. firstpass(right);
  1247. if codegenerror then
  1248. exit;
  1249. { load easier access variables }
  1250. rd:=right.resulttype.def;
  1251. ld:=left.resulttype.def;
  1252. rt:=right.nodetype;
  1253. lt:=left.nodetype;
  1254. { int/int gives real/real! }
  1255. if nodetype=slashn then
  1256. begin
  1257. location.loc:=LOC_FPUREGISTER;
  1258. { maybe we need an integer register to save }
  1259. { a reference }
  1260. if ((left.location.loc<>LOC_FPUREGISTER) or
  1261. (right.location.loc<>LOC_FPUREGISTER)) and
  1262. (left.registers32=right.registers32) then
  1263. calcregisters(self,1,1,0)
  1264. else
  1265. calcregisters(self,0,1,0);
  1266. { an add node always first loads both the left and the }
  1267. { right in the fpu before doing the calculation. However, }
  1268. { calcregisters(0,2,0) will overestimate the number of }
  1269. { necessary registers (it will make it 3 in case one of }
  1270. { the operands is already in the fpu) (JM) }
  1271. if ((left.location.loc <> LOC_FPUREGISTER) or
  1272. (right.location.loc <> LOC_FPUREGISTER)) and
  1273. (registersfpu < 2) then
  1274. inc(registersfpu);
  1275. end
  1276. { if both are orddefs then check sub types }
  1277. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  1278. begin
  1279. { 2 booleans ? }
  1280. if is_boolean(ld) and is_boolean(rd) then
  1281. begin
  1282. if not(cs_full_boolean_eval in aktlocalswitches) and
  1283. (nodetype in [andn,orn]) then
  1284. begin
  1285. location.loc:=LOC_JUMP;
  1286. calcregisters(self,0,0,0);
  1287. end
  1288. else
  1289. begin
  1290. location.loc := LOC_FLAGS;
  1291. if (left.location.loc in [LOC_JUMP,LOC_FLAGS]) and
  1292. (left.location.loc in [LOC_JUMP,LOC_FLAGS]) then
  1293. calcregisters(self,2,0,0)
  1294. else
  1295. calcregisters(self,1,0,0);
  1296. end;
  1297. end
  1298. else
  1299. { Both are chars? only convert to shortstrings for addn }
  1300. if is_char(ld) then
  1301. begin
  1302. if nodetype=addn then
  1303. internalerror(200103291);
  1304. location.loc := LOC_FLAGS;
  1305. calcregisters(self,1,0,0);
  1306. end
  1307. { is there a 64 bit type ? }
  1308. else if (torddef(ld).typ in [s64bit,u64bit]) then
  1309. begin
  1310. result := first_add64bitint;
  1311. if assigned(result) then
  1312. exit;
  1313. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1314. location.loc := LOC_REGISTER
  1315. else
  1316. location.loc := LOC_JUMP;
  1317. calcregisters(self,2,0,0)
  1318. end
  1319. { is there a cardinal? }
  1320. else if (torddef(ld).typ=u32bit) then
  1321. begin
  1322. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1323. location.loc := LOC_REGISTER
  1324. else
  1325. location.loc := LOC_FLAGS;
  1326. calcregisters(self,1,0,0);
  1327. { for unsigned mul we need an extra register }
  1328. if nodetype=muln then
  1329. inc(registers32);
  1330. end
  1331. { generic s32bit conversion }
  1332. else
  1333. begin
  1334. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  1335. location.loc := LOC_REGISTER
  1336. else
  1337. location.loc := LOC_FLAGS;
  1338. calcregisters(self,1,0,0);
  1339. end;
  1340. end
  1341. { left side a setdef, must be before string processing,
  1342. else array constructor can be seen as array of char (PFV) }
  1343. else if (ld.deftype=setdef) then
  1344. begin
  1345. if tsetdef(ld).settype=smallset then
  1346. begin
  1347. location.loc:=LOC_REGISTER;
  1348. { are we adding set elements ? }
  1349. if right.nodetype=setelementn then
  1350. calcregisters(self,2,0,0)
  1351. else
  1352. calcregisters(self,1,0,0);
  1353. end
  1354. else
  1355. begin
  1356. result := first_addset;
  1357. if assigned(result) then
  1358. exit;
  1359. location.loc:=LOC_CREFERENCE;
  1360. calcregisters(self,0,0,0);
  1361. { here we call SET... }
  1362. if assigned(procinfo) then
  1363. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1364. end;
  1365. end
  1366. { compare pchar by addresses like BP/Delphi }
  1367. else if is_pchar(ld) then
  1368. begin
  1369. location.loc:=LOC_REGISTER;
  1370. calcregisters(self,1,0,0);
  1371. end
  1372. { is one of the operands a string }
  1373. else if (ld.deftype=stringdef) then
  1374. begin
  1375. if is_widestring(ld) then
  1376. begin
  1377. { we use reference counted widestrings so no fast exit here }
  1378. if assigned(procinfo) then
  1379. procinfo^.no_fast_exit:=true;
  1380. { this is only for add, the comparisaion is handled later }
  1381. location.loc:=LOC_REGISTER;
  1382. end
  1383. else if is_ansistring(ld) then
  1384. begin
  1385. { we use ansistrings so no fast exit here }
  1386. if assigned(procinfo) then
  1387. procinfo^.no_fast_exit:=true;
  1388. { this is only for add, the comparisaion is handled later }
  1389. location.loc:=LOC_REGISTER;
  1390. end
  1391. else if is_longstring(ld) then
  1392. begin
  1393. { this is only for add, the comparisaion is handled later }
  1394. location.loc:=LOC_CREFERENCE;
  1395. end
  1396. else
  1397. begin
  1398. if canbeaddsstringcharoptnode(self) then
  1399. begin
  1400. hp := genaddsstringcharoptnode(self);
  1401. firstpass(hp);
  1402. pass_1 := hp;
  1403. exit;
  1404. end
  1405. else
  1406. begin
  1407. { Fix right to be shortstring }
  1408. if is_char(right.resulttype.def) then
  1409. begin
  1410. inserttypeconv(right,cshortstringtype);
  1411. firstpass(right);
  1412. end;
  1413. end;
  1414. if canbeaddsstringcsstringoptnode(self) then
  1415. begin
  1416. hp := genaddsstringcsstringoptnode(self);
  1417. firstpass(hp);
  1418. pass_1 := hp;
  1419. exit;
  1420. end;
  1421. end;
  1422. { otherwise, let addstring convert everything }
  1423. result := first_addstring;
  1424. exit;
  1425. end
  1426. { is one a real float ? }
  1427. else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
  1428. begin
  1429. location.loc:=LOC_FPUREGISTER;
  1430. calcregisters(self,0,1,0);
  1431. { an add node always first loads both the left and the }
  1432. { right in the fpu before doing the calculation. However, }
  1433. { calcregisters(0,2,0) will overestimate the number of }
  1434. { necessary registers (it will make it 3 in case one of }
  1435. { the operands is already in the fpu) (JM) }
  1436. if ((left.location.loc <> LOC_FPUREGISTER) or
  1437. (right.location.loc <> LOC_FPUREGISTER)) and
  1438. (registersfpu < 2) then
  1439. inc(registersfpu);
  1440. end
  1441. { pointer comperation and subtraction }
  1442. else if (ld.deftype=pointerdef) then
  1443. begin
  1444. location.loc:=LOC_REGISTER;
  1445. calcregisters(self,1,0,0);
  1446. end
  1447. else if is_class_or_interface(ld) then
  1448. begin
  1449. location.loc:=LOC_REGISTER;
  1450. calcregisters(self,1,0,0);
  1451. end
  1452. else if (ld.deftype=classrefdef) then
  1453. begin
  1454. location.loc:=LOC_REGISTER;
  1455. calcregisters(self,1,0,0);
  1456. end
  1457. { support procvar=nil,procvar<>nil }
  1458. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1459. ((rd.deftype=procvardef) and (lt=niln)) then
  1460. begin
  1461. location.loc:=LOC_REGISTER;
  1462. calcregisters(self,1,0,0);
  1463. end
  1464. {$ifdef SUPPORT_MMX}
  1465. { mmx support, this must be before the zero based array
  1466. check }
  1467. else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
  1468. is_mmx_able_array(rd) then
  1469. begin
  1470. location.loc:=LOC_MMXREGISTER;
  1471. calcregisters(self,0,0,1);
  1472. end
  1473. {$endif SUPPORT_MMX}
  1474. else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
  1475. begin
  1476. location.loc:=LOC_REGISTER;
  1477. calcregisters(self,1,0,0);
  1478. end
  1479. else if (rd.deftype=procvardef) and (ld.deftype=procvardef) and is_equal(rd,ld) then
  1480. begin
  1481. location.loc:=LOC_REGISTER;
  1482. calcregisters(self,1,0,0);
  1483. end
  1484. else if (ld.deftype=enumdef) then
  1485. begin
  1486. location.loc := LOC_FLAGS;
  1487. calcregisters(self,1,0,0);
  1488. end
  1489. {$ifdef SUPPORT_MMX}
  1490. else if (cs_mmx in aktlocalswitches) and
  1491. is_mmx_able_array(ld) and
  1492. is_mmx_able_array(rd) then
  1493. begin
  1494. location.loc:=LOC_MMXREGISTER;
  1495. calcregisters(self,0,0,1);
  1496. end
  1497. {$endif SUPPORT_MMX}
  1498. { the general solution is to convert to 32 bit int }
  1499. else
  1500. begin
  1501. location.loc:=LOC_REGISTER;
  1502. calcregisters(self,1,0,0);
  1503. end;
  1504. end;
  1505. begin
  1506. caddnode:=taddnode;
  1507. end.
  1508. {
  1509. $Log$
  1510. Revision 1.45 2002-04-04 19:05:56 peter
  1511. * removed unused units
  1512. * use tlocation.size in cg.a_*loc*() routines
  1513. Revision 1.44 2002/04/02 17:11:28 peter
  1514. * tlocation,treference update
  1515. * LOC_CONSTANT added for better constant handling
  1516. * secondadd splitted in multiple routines
  1517. * location_force_reg added for loading a location to a register
  1518. of a specified size
  1519. * secondassignment parses now first the right and then the left node
  1520. (this is compatible with Kylix). This saves a lot of push/pop especially
  1521. with string operations
  1522. * adapted some routines to use the new cg methods
  1523. Revision 1.43 2002/03/30 23:12:09 carl
  1524. * avoid crash with procinfo ('merged')
  1525. Revision 1.42 2001/12/27 15:33:58 jonas
  1526. * fixed fpuregister counting errors ("merged")
  1527. Revision 1.41 2001/10/20 19:28:37 peter
  1528. * interface 2 guid support
  1529. * guid constants support
  1530. Revision 1.40 2001/10/12 13:51:51 jonas
  1531. * fixed internalerror(10) due to previous fpu overflow fixes ("merged")
  1532. * fixed bug in n386add (introduced after compilerproc changes for string
  1533. operations) where calcregisters wasn't called for shortstring addnodes
  1534. * NOTE: from now on, the location of a binary node must now always be set
  1535. before you call calcregisters() for it
  1536. Revision 1.39 2001/09/05 15:22:09 jonas
  1537. * made multiplying, dividing and mod'ing of int64 and qword processor
  1538. independent with compilerprocs (+ small optimizations by using shift/and
  1539. where possible)
  1540. Revision 1.38 2001/09/04 11:38:54 jonas
  1541. + searchsystype() and searchsystype() functions in symtable
  1542. * changed ninl and nadd to use these functions
  1543. * i386 set comparison functions now return their results in al instead
  1544. of in the flags so that they can be sued as compilerprocs
  1545. - removed all processor specific code from n386add.pas that has to do
  1546. with set handling, it's now all done in nadd.pas
  1547. * fixed fpc_set_contains_sets in genset.inc
  1548. * fpc_set_in_byte is now coded inline in n386set.pas and doesn't use a
  1549. helper anymore
  1550. * some small fixes in compproc.inc/set.inc regarding the declaration of
  1551. internal helper types (fpc_small_set and fpc_normal_set)
  1552. Revision 1.37 2001/09/03 13:27:42 jonas
  1553. * compilerproc implementation of set addition/substraction/...
  1554. * changed the declaration of some set helpers somewhat to accomodate the
  1555. above change
  1556. * i386 still uses the old code for comparisons of sets, because its
  1557. helpers return the results in the flags
  1558. * dummy tc_normal_2_small_set type conversion because I need the original
  1559. resulttype of the set add nodes
  1560. NOTE: you have to start a cycle with 1.0.5!
  1561. Revision 1.36 2001/09/02 21:12:06 peter
  1562. * move class of definitions into type section for delphi
  1563. Revision 1.35 2001/08/31 15:42:15 jonas
  1564. * added missing type conversion from small to normal sets
  1565. Revision 1.34 2001/08/30 15:43:14 jonas
  1566. * converted adding/comparing of strings to compileproc. Note that due
  1567. to the way the shortstring helpers for i386 are written, they are
  1568. still handled by the old code (reason: fpc_shortstr_compare returns
  1569. results in the flags instead of in eax and fpc_shortstr_concat
  1570. has wierd parameter conventions). The compilerproc stuff should work
  1571. fine with the generic implementations though.
  1572. * removed some nested comments warnings
  1573. Revision 1.33 2001/08/26 13:36:38 florian
  1574. * some cg reorganisation
  1575. * some PPC updates
  1576. Revision 1.32 2001/08/06 21:40:46 peter
  1577. * funcret moved from tprocinfo to tprocdef
  1578. Revision 1.31 2001/07/08 21:00:14 peter
  1579. * various widestring updates, it works now mostly without charset
  1580. mapping supported
  1581. Revision 1.30 2001/06/04 21:41:26 peter
  1582. * readded generic conversion to s32bit that i removed yesterday. It
  1583. is still used for error recovery, added a small note about that
  1584. Revision 1.29 2001/06/04 18:13:53 peter
  1585. * Support kylix hack of having enum+integer in a enum declaration.
  1586. Revision 1.28 2001/05/27 14:30:55 florian
  1587. + some widestring stuff added
  1588. Revision 1.27 2001/05/19 21:11:50 peter
  1589. * first check for overloaded operator before doing inserting any
  1590. typeconvs
  1591. Revision 1.26 2001/05/19 12:53:52 peter
  1592. * check set types when doing constant set evaluation
  1593. Revision 1.25 2001/04/13 01:22:08 peter
  1594. * symtable change to classes
  1595. * range check generation and errors fixed, make cycle DEBUG=1 works
  1596. * memory leaks fixed
  1597. Revision 1.24 2001/04/04 22:42:39 peter
  1598. * move constant folding into det_resulttype
  1599. Revision 1.23 2001/04/02 21:20:30 peter
  1600. * resulttype rewrite
  1601. Revision 1.22 2001/02/04 11:12:17 jonas
  1602. * fixed web bug 1377 & const pointer arithmtic
  1603. Revision 1.21 2001/01/14 22:13:13 peter
  1604. * constant calculation fixed. The type of the new constant is now
  1605. defined after the calculation is done. This should remove a lot
  1606. of wrong warnings (and errors with -Cr).
  1607. Revision 1.20 2000/12/31 11:14:10 jonas
  1608. + implemented/fixed docompare() mathods for all nodes (not tested)
  1609. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1610. and constant strings/chars together
  1611. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1612. when adding
  1613. Revision 1.19 2000/12/16 15:55:32 jonas
  1614. + warning when there is a chance to get a range check error because of
  1615. automatic type conversion to u32bit
  1616. * arithmetic operations with a cardinal and a signed operand are carried
  1617. out in 64bit when range checking is on ("merged" from fixes branch)
  1618. Revision 1.18 2000/11/29 00:30:31 florian
  1619. * unused units removed from uses clause
  1620. * some changes for widestrings
  1621. Revision 1.17 2000/11/20 15:30:42 jonas
  1622. * changed types of values used for constant expression evaluation to
  1623. tconstexprint
  1624. Revision 1.16 2000/11/13 11:30:55 florian
  1625. * some bugs with interfaces and NIL fixed
  1626. Revision 1.15 2000/11/04 14:25:20 florian
  1627. + merged Attila's changes for interfaces, not tested yet
  1628. Revision 1.14 2000/10/31 22:02:47 peter
  1629. * symtable splitted, no real code changes
  1630. Revision 1.13 2000/10/14 10:14:50 peter
  1631. * moehrendorf oct 2000 rewrite
  1632. Revision 1.12 2000/10/01 19:48:23 peter
  1633. * lot of compile updates for cg11
  1634. Revision 1.11 2000/09/30 16:08:45 peter
  1635. * more cg11 updates
  1636. Revision 1.10 2000/09/28 19:49:52 florian
  1637. *** empty log message ***
  1638. Revision 1.9 2000/09/27 21:33:22 florian
  1639. * finally nadd.pas compiles
  1640. Revision 1.8 2000/09/27 20:25:44 florian
  1641. * more stuff fixed
  1642. Revision 1.7 2000/09/27 18:14:31 florian
  1643. * fixed a lot of syntax errors in the n*.pas stuff
  1644. Revision 1.6 2000/09/24 15:06:19 peter
  1645. * use defines.inc
  1646. Revision 1.5 2000/09/22 22:42:52 florian
  1647. * more fixes
  1648. Revision 1.4 2000/09/21 12:22:42 jonas
  1649. * put piece of code between -dnewoptimizations2 since it wasn't
  1650. necessary otherwise
  1651. + support for full boolean evaluation (from tcadd)
  1652. Revision 1.3 2000/09/20 21:50:59 florian
  1653. * updated
  1654. Revision 1.2 2000/08/29 08:24:45 jonas
  1655. * some modifications to -dcardinalmulfix code
  1656. Revision 1.1 2000/08/26 12:24:20 florian
  1657. * initial release
  1658. }