nadd.pas 66 KB

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