nadd.pas 68 KB

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