nadd.pas 89 KB

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