nadd.pas 94 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Type checking and register allocation for add nodes
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit nadd;
  18. {$i fpcdefs.inc}
  19. { define addstringopt}
  20. interface
  21. uses
  22. node,symtype;
  23. type
  24. taddnode = class(tbinopnode)
  25. resultrealtype : ttype;
  26. constructor create(tt : tnodetype;l,r : tnode);override;
  27. function pass_1 : tnode;override;
  28. function det_resulttype:tnode;override;
  29. function simplify : tnode;override;
  30. {$ifdef state_tracking}
  31. function track_state_pass(exec_known:boolean):boolean;override;
  32. {$endif}
  33. protected
  34. { override the following if you want to implement }
  35. { parts explicitely in the code generator (JM) }
  36. function first_addstring: tnode; virtual;
  37. function first_addset: tnode; virtual;
  38. { only implements "muln" nodes, the rest always has to be done in }
  39. { the code generator for performance reasons (JM) }
  40. function first_add64bitint: tnode; virtual;
  41. { override and return false if you can handle 32x32->64 }
  42. { bit multiplies directly in your code generator. If }
  43. { this function is overridden to return false, you can }
  44. { get multiplies with left/right both s32bit or u32bit, }
  45. { and resulttype of the muln s64bit or u64bit }
  46. function use_generic_mul32to64: boolean; virtual;
  47. { This routine calls internal runtime library helpers
  48. for all floating point arithmetic in the case
  49. where the emulation switches is on. Otherwise
  50. returns nil, and everything must be done in
  51. the code generation phase.
  52. }
  53. function first_addfloat : tnode; virtual;
  54. private
  55. { checks whether a muln can be calculated as a 32bit }
  56. { * 32bit -> 64 bit }
  57. function try_make_mul32to64: boolean;
  58. end;
  59. taddnodeclass = class of taddnode;
  60. var
  61. { caddnode is used to create nodes of the add type }
  62. { the virtual constructor allows to assign }
  63. { another class type to caddnode => processor }
  64. { specific node types can be created }
  65. caddnode : taddnodeclass;
  66. implementation
  67. uses
  68. {$IFNDEF USE_FAKE_SYSUTILS}
  69. sysutils,
  70. {$ELSE}
  71. fksysutl,
  72. {$ENDIF}
  73. globtype,systems,
  74. cutils,verbose,globals,widestr,
  75. symconst,symdef,symsym,symtable,defutil,defcmp,
  76. cgbase,
  77. htypechk,pass_1,
  78. nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
  79. {$ifdef state_tracking}
  80. nstate,
  81. {$endif}
  82. cpuinfo,procinfo;
  83. {*****************************************************************************
  84. TADDNODE
  85. *****************************************************************************}
  86. {$ifdef fpc}
  87. {$maxfpuregisters 0}
  88. {$endif fpc}
  89. function getbestreal(const t1,t2 : ttype) : ttype;
  90. const
  91. floatweight : array[tfloattype] of byte =
  92. (2,3,4,0,1,5);
  93. begin
  94. if t1.def.deftype=floatdef then
  95. begin
  96. result:=t1;
  97. if t2.def.deftype=floatdef then
  98. begin
  99. { when a comp or currency is used, use always the
  100. best float type to calculate the result }
  101. if (tfloatdef(t2.def).typ in [s64comp,s64currency]) or
  102. (tfloatdef(t2.def).typ in [s64comp,s64currency]) then
  103. result:=pbestrealtype^
  104. else
  105. if floatweight[tfloatdef(t2.def).typ]>floatweight[tfloatdef(t1.def).typ] then
  106. result:=t2;
  107. end;
  108. end
  109. else if t2.def.deftype=floatdef then
  110. result:=t2
  111. else internalerror(200508061);
  112. end;
  113. constructor taddnode.create(tt : tnodetype;l,r : tnode);
  114. begin
  115. inherited create(tt,l,r);
  116. end;
  117. function taddnode.simplify : tnode;
  118. var
  119. t : tnode;
  120. lt,rt : tnodetype;
  121. rd,ld : tdef;
  122. rv,lv : tconstexprint;
  123. rvd,lvd : bestreal;
  124. ws1,ws2 : pcompilerwidestring;
  125. concatstrings : boolean;
  126. c1,c2 : array[0..1] of char;
  127. s1,s2 : pchar;
  128. l1,l2 : longint;
  129. resultset : Tconstset;
  130. b : boolean;
  131. begin
  132. result:=nil;
  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. resultrealtype:=pbestrealtype^;
  137. if (right.resulttype.def.deftype=floatdef) or (left.resulttype.def.deftype=floatdef) then
  138. begin
  139. { when both floattypes are already equal then use that
  140. floattype for results }
  141. if (right.resulttype.def.deftype=floatdef) and
  142. (left.resulttype.def.deftype=floatdef) and
  143. (tfloatdef(left.resulttype.def).typ=tfloatdef(right.resulttype.def).typ) then
  144. resultrealtype:=left.resulttype
  145. { when there is a currency type then use currency, but
  146. only when currency is defined as float }
  147. else
  148. if (is_currency(right.resulttype.def) or
  149. is_currency(left.resulttype.def)) and
  150. ((s64currencytype.def.deftype = floatdef) or
  151. (nodetype <> slashn)) then
  152. begin
  153. resultrealtype:=s64currencytype;
  154. inserttypeconv(right,resultrealtype);
  155. inserttypeconv(left,resultrealtype);
  156. end
  157. else
  158. begin
  159. resultrealtype:=getbestreal(left.resulttype,right.resulttype);
  160. inserttypeconv(right,resultrealtype);
  161. inserttypeconv(left,resultrealtype);
  162. end;
  163. end;
  164. { If both operands are constant and there is a widechar
  165. or widestring then convert everything to widestring. This
  166. allows constant folding like char+widechar }
  167. if is_constnode(right) and is_constnode(left) and
  168. (is_widestring(right.resulttype.def) or
  169. is_widestring(left.resulttype.def) or
  170. is_widechar(right.resulttype.def) or
  171. is_widechar(left.resulttype.def)) then
  172. begin
  173. inserttypeconv(right,cwidestringtype);
  174. inserttypeconv(left,cwidestringtype);
  175. end;
  176. { load easier access variables }
  177. rd:=right.resulttype.def;
  178. ld:=left.resulttype.def;
  179. rt:=right.nodetype;
  180. lt:=left.nodetype;
  181. if (nodetype = slashn) and
  182. (((rt = ordconstn) and
  183. (tordconstnode(right).value = 0)) or
  184. ((rt = realconstn) and
  185. (trealconstnode(right).value_real = 0.0))) then
  186. begin
  187. if (cs_check_range in aktlocalswitches) or
  188. (cs_check_overflow in aktlocalswitches) then
  189. begin
  190. result:=crealconstnode.create(1,pbestrealtype^);
  191. Message(parser_e_division_by_zero);
  192. exit;
  193. end;
  194. end;
  195. { both are int constants }
  196. if (
  197. (
  198. is_constintnode(left) and
  199. is_constintnode(right)
  200. ) or
  201. (
  202. is_constboolnode(left) and
  203. is_constboolnode(right) and
  204. (nodetype in [slashn,ltn,lten,gtn,gten,equaln,unequaln,andn,xorn,orn])
  205. ) or
  206. (
  207. is_constenumnode(left) and
  208. is_constenumnode(right) and
  209. allowenumop(nodetype))
  210. ) or
  211. (
  212. (lt = pointerconstn) and
  213. is_constintnode(right) and
  214. (nodetype in [addn,subn])
  215. ) or
  216. (
  217. (lt in [pointerconstn,niln]) and
  218. (rt in [pointerconstn,niln]) and
  219. (nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])
  220. ) then
  221. begin
  222. t:=nil;
  223. { when comparing/substracting pointers, make sure they are }
  224. { of the same type (JM) }
  225. if (lt = pointerconstn) and (rt = pointerconstn) then
  226. begin
  227. if not(cs_extsyntax in aktmoduleswitches) and
  228. not(nodetype in [equaln,unequaln]) then
  229. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename)
  230. else
  231. if (nodetype <> subn) and
  232. is_voidpointer(rd) then
  233. inserttypeconv(right,left.resulttype)
  234. else if (nodetype <> subn) and
  235. is_voidpointer(ld) then
  236. inserttypeconv(left,right.resulttype)
  237. else if not(equal_defs(ld,rd)) then
  238. IncompatibleTypes(ld,rd);
  239. end
  240. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  241. begin
  242. if not(equal_defs(ld,rd)) then
  243. inserttypeconv(right,left.resulttype);
  244. end;
  245. { load values }
  246. case lt of
  247. ordconstn:
  248. lv:=tordconstnode(left).value;
  249. pointerconstn:
  250. lv:=tpointerconstnode(left).value;
  251. niln:
  252. lv:=0;
  253. else
  254. internalerror(2002080202);
  255. end;
  256. case rt of
  257. ordconstn:
  258. rv:=tordconstnode(right).value;
  259. pointerconstn:
  260. rv:=tpointerconstnode(right).value;
  261. niln:
  262. rv:=0;
  263. else
  264. internalerror(2002080203);
  265. end;
  266. if (lt = pointerconstn) and
  267. (rt <> pointerconstn) then
  268. rv := rv * tpointerdef(left.resulttype.def).pointertype.def.size;
  269. if (rt = pointerconstn) and
  270. (lt <> pointerconstn) then
  271. lv := lv * tpointerdef(right.resulttype.def).pointertype.def.size;
  272. case nodetype of
  273. addn :
  274. begin
  275. {$ifopt Q-}
  276. {$define OVERFLOW_OFF}
  277. {$Q+}
  278. {$endif}
  279. try
  280. if (lt=pointerconstn) then
  281. t := cpointerconstnode.create(lv+rv,left.resulttype)
  282. else
  283. if is_integer(ld) then
  284. t := genintconstnode(lv+rv)
  285. else
  286. t := cordconstnode.create(lv+rv,left.resulttype,(ld.deftype<>enumdef));
  287. except
  288. on E:EIntOverflow do
  289. begin
  290. Message(parser_e_arithmetic_operation_overflow);
  291. { Recover }
  292. t:=genintconstnode(0)
  293. end;
  294. end;
  295. {$ifdef OVERFLOW_OFF}
  296. {$Q-}
  297. {$undef OVERFLOW_OFF}
  298. {$endif}
  299. end;
  300. subn :
  301. begin
  302. {$ifopt Q-}
  303. {$define OVERFLOW_OFF}
  304. {$Q+}
  305. {$endif}
  306. try
  307. if (lt=pointerconstn) then
  308. begin
  309. { pointer-pointer results in an integer }
  310. if (rt=pointerconstn) then
  311. t := genintconstnode((lv-rv) div tpointerdef(ld).pointertype.def.size)
  312. else
  313. t := cpointerconstnode.create(lv-rv,left.resulttype);
  314. end
  315. else
  316. begin
  317. if is_integer(ld) then
  318. t:=genintconstnode(lv-rv)
  319. else
  320. t:=cordconstnode.create(lv-rv,left.resulttype,(ld.deftype<>enumdef));
  321. end;
  322. except
  323. on E:EIntOverflow do
  324. begin
  325. Message(parser_e_arithmetic_operation_overflow);
  326. { Recover }
  327. t:=genintconstnode(0)
  328. end;
  329. end;
  330. {$ifdef OVERFLOW_OFF}
  331. {$Q-}
  332. {$undef OVERFLOW_OFF}
  333. {$endif}
  334. end;
  335. muln :
  336. begin
  337. {$ifopt Q-}
  338. {$define OVERFLOW_OFF}
  339. {$Q+}
  340. {$endif}
  341. try
  342. if (torddef(ld).typ <> u64bit) or
  343. (torddef(rd).typ <> u64bit) then
  344. t:=genintconstnode(lv*rv)
  345. else
  346. t:=genintconstnode(int64(qword(lv)*qword(rv)));
  347. except
  348. on E:EIntOverflow do
  349. begin
  350. Message(parser_e_arithmetic_operation_overflow);
  351. { Recover }
  352. t:=genintconstnode(0)
  353. end;
  354. end;
  355. {$ifdef OVERFLOW_OFF}
  356. {$Q-}
  357. {$undef OVERFLOW_OFF}
  358. {$endif}
  359. end;
  360. xorn :
  361. if is_integer(ld) then
  362. t:=genintconstnode(lv xor rv)
  363. else
  364. t:=cordconstnode.create(lv xor rv,left.resulttype,true);
  365. orn :
  366. if is_integer(ld) then
  367. t:=genintconstnode(lv or rv)
  368. else
  369. t:=cordconstnode.create(lv or rv,left.resulttype,true);
  370. andn :
  371. if is_integer(ld) then
  372. t:=genintconstnode(lv and rv)
  373. else
  374. t:=cordconstnode.create(lv and rv,left.resulttype,true);
  375. ltn :
  376. t:=cordconstnode.create(ord(lv<rv),booltype,true);
  377. lten :
  378. t:=cordconstnode.create(ord(lv<=rv),booltype,true);
  379. gtn :
  380. t:=cordconstnode.create(ord(lv>rv),booltype,true);
  381. gten :
  382. t:=cordconstnode.create(ord(lv>=rv),booltype,true);
  383. equaln :
  384. t:=cordconstnode.create(ord(lv=rv),booltype,true);
  385. unequaln :
  386. t:=cordconstnode.create(ord(lv<>rv),booltype,true);
  387. slashn :
  388. begin
  389. { int/int becomes a real }
  390. rvd:=rv;
  391. lvd:=lv;
  392. t:=crealconstnode.create(lvd/rvd,resultrealtype);
  393. end;
  394. else
  395. begin
  396. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  397. t:=cnothingnode.create;
  398. end;
  399. end;
  400. result:=t;
  401. exit;
  402. end;
  403. { both real constants ? }
  404. if (lt=realconstn) and (rt=realconstn) then
  405. begin
  406. lvd:=trealconstnode(left).value_real;
  407. rvd:=trealconstnode(right).value_real;
  408. case nodetype of
  409. addn :
  410. t:=crealconstnode.create(lvd+rvd,resultrealtype);
  411. subn :
  412. t:=crealconstnode.create(lvd-rvd,resultrealtype);
  413. muln :
  414. t:=crealconstnode.create(lvd*rvd,resultrealtype);
  415. starstarn,
  416. caretn :
  417. begin
  418. if lvd<0 then
  419. begin
  420. Message(parser_e_invalid_float_operation);
  421. t:=crealconstnode.create(0,resultrealtype);
  422. end
  423. else if lvd=0 then
  424. t:=crealconstnode.create(1.0,resultrealtype)
  425. else
  426. t:=crealconstnode.create(exp(ln(lvd)*rvd),resultrealtype);
  427. end;
  428. slashn :
  429. t:=crealconstnode.create(lvd/rvd,resultrealtype);
  430. ltn :
  431. t:=cordconstnode.create(ord(lvd<rvd),booltype,true);
  432. lten :
  433. t:=cordconstnode.create(ord(lvd<=rvd),booltype,true);
  434. gtn :
  435. t:=cordconstnode.create(ord(lvd>rvd),booltype,true);
  436. gten :
  437. t:=cordconstnode.create(ord(lvd>=rvd),booltype,true);
  438. equaln :
  439. t:=cordconstnode.create(ord(lvd=rvd),booltype,true);
  440. unequaln :
  441. t:=cordconstnode.create(ord(lvd<>rvd),booltype,true);
  442. else
  443. begin
  444. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  445. t:=cnothingnode.create;
  446. end;
  447. end;
  448. result:=t;
  449. exit;
  450. end;
  451. { first, we handle widestrings, so we can check later for }
  452. { stringconstn only }
  453. { widechars are converted above to widestrings too }
  454. { this isn't veryy efficient, but I don't think }
  455. { that it does matter that much (FK) }
  456. if (lt=stringconstn) and (rt=stringconstn) and
  457. (tstringconstnode(left).cst_type=cst_widestring) and
  458. (tstringconstnode(right).cst_type=cst_widestring) then
  459. begin
  460. initwidestring(ws1);
  461. initwidestring(ws2);
  462. copywidestring(pcompilerwidestring(tstringconstnode(left).value_str),ws1);
  463. copywidestring(pcompilerwidestring(tstringconstnode(right).value_str),ws2);
  464. case nodetype of
  465. addn :
  466. begin
  467. concatwidestrings(ws1,ws2);
  468. t:=cstringconstnode.createwstr(ws1);
  469. end;
  470. ltn :
  471. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<0),booltype,true);
  472. lten :
  473. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<=0),booltype,true);
  474. gtn :
  475. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>0),booltype,true);
  476. gten :
  477. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)>=0),booltype,true);
  478. equaln :
  479. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)=0),booltype,true);
  480. unequaln :
  481. t:=cordconstnode.create(byte(comparewidestrings(ws1,ws2)<>0),booltype,true);
  482. else
  483. begin
  484. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  485. t:=cnothingnode.create;
  486. end;
  487. end;
  488. donewidestring(ws1);
  489. donewidestring(ws2);
  490. result:=t;
  491. exit;
  492. end;
  493. { concating strings ? }
  494. concatstrings:=false;
  495. if (lt=ordconstn) and (rt=ordconstn) and
  496. is_char(ld) and is_char(rd) then
  497. begin
  498. c1[0]:=char(byte(tordconstnode(left).value));
  499. c1[1]:=#0;
  500. l1:=1;
  501. c2[0]:=char(byte(tordconstnode(right).value));
  502. c2[1]:=#0;
  503. l2:=1;
  504. s1:=@c1;
  505. s2:=@c2;
  506. concatstrings:=true;
  507. end
  508. else if (lt=stringconstn) and (rt=ordconstn) and is_char(rd) then
  509. begin
  510. s1:=tstringconstnode(left).value_str;
  511. l1:=tstringconstnode(left).len;
  512. c2[0]:=char(byte(tordconstnode(right).value));
  513. c2[1]:=#0;
  514. s2:=@c2;
  515. l2:=1;
  516. concatstrings:=true;
  517. end
  518. else if (lt=ordconstn) and (rt=stringconstn) and is_char(ld) then
  519. begin
  520. c1[0]:=char(byte(tordconstnode(left).value));
  521. c1[1]:=#0;
  522. l1:=1;
  523. s1:=@c1;
  524. s2:=tstringconstnode(right).value_str;
  525. l2:=tstringconstnode(right).len;
  526. concatstrings:=true;
  527. end
  528. else if (lt=stringconstn) and (rt=stringconstn) then
  529. begin
  530. s1:=tstringconstnode(left).value_str;
  531. l1:=tstringconstnode(left).len;
  532. s2:=tstringconstnode(right).value_str;
  533. l2:=tstringconstnode(right).len;
  534. concatstrings:=true;
  535. end;
  536. if concatstrings then
  537. begin
  538. case nodetype of
  539. addn :
  540. t:=cstringconstnode.createpchar(concatansistrings(s1,s2,l1,l2),l1+l2);
  541. ltn :
  542. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<0),booltype,true);
  543. lten :
  544. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<=0),booltype,true);
  545. gtn :
  546. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>0),booltype,true);
  547. gten :
  548. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)>=0),booltype,true);
  549. equaln :
  550. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)=0),booltype,true);
  551. unequaln :
  552. t:=cordconstnode.create(byte(compareansistrings(s1,s2,l1,l2)<>0),booltype,true);
  553. else
  554. begin
  555. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  556. t:=cnothingnode.create;
  557. end;
  558. end;
  559. result:=t;
  560. exit;
  561. end;
  562. { set constant evaluation }
  563. if (right.nodetype=setconstn) and
  564. not assigned(tsetconstnode(right).left) and
  565. (left.nodetype=setconstn) and
  566. not assigned(tsetconstnode(left).left) then
  567. begin
  568. { check if size adjusting is needed, only for left
  569. to right as the other way is checked in the typeconv }
  570. if (tsetdef(right.resulttype.def).settype=smallset) and
  571. (tsetdef(left.resulttype.def).settype<>smallset) then
  572. right.resulttype.setdef(tsetdef.create(tsetdef(right.resulttype.def).elementtype,255));
  573. { check base types }
  574. inserttypeconv(left,right.resulttype);
  575. if codegenerror then
  576. begin
  577. { recover by only returning the left part }
  578. result:=left;
  579. left:=nil;
  580. exit;
  581. end;
  582. case nodetype of
  583. addn :
  584. begin
  585. resultset:=tsetconstnode(right).value_set^ + tsetconstnode(left).value_set^;
  586. t:=csetconstnode.create(@resultset,left.resulttype);
  587. end;
  588. muln :
  589. begin
  590. resultset:=tsetconstnode(right).value_set^ * tsetconstnode(left).value_set^;
  591. t:=csetconstnode.create(@resultset,left.resulttype);
  592. end;
  593. subn :
  594. begin
  595. resultset:=tsetconstnode(left).value_set^ - tsetconstnode(right).value_set^;
  596. t:=csetconstnode.create(@resultset,left.resulttype);
  597. end;
  598. symdifn :
  599. begin
  600. resultset:=tsetconstnode(right).value_set^ >< tsetconstnode(left).value_set^;
  601. t:=csetconstnode.create(@resultset,left.resulttype);
  602. end;
  603. unequaln :
  604. begin
  605. b:=tsetconstnode(right).value_set^ <> tsetconstnode(left).value_set^;
  606. t:=cordconstnode.create(byte(b),booltype,true);
  607. end;
  608. equaln :
  609. begin
  610. b:=tsetconstnode(right).value_set^ = tsetconstnode(left).value_set^;
  611. t:=cordconstnode.create(byte(b),booltype,true);
  612. end;
  613. lten :
  614. begin
  615. b:=tsetconstnode(left).value_set^ <= tsetconstnode(right).value_set^;
  616. t:=cordconstnode.create(byte(b),booltype,true);
  617. end;
  618. gten :
  619. begin
  620. b:=tsetconstnode(left).value_set^ >= tsetconstnode(right).value_set^;
  621. t:=cordconstnode.create(byte(b),booltype,true);
  622. end;
  623. else
  624. begin
  625. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  626. t:=cnothingnode.create;
  627. end;
  628. end;
  629. result:=t;
  630. exit;
  631. end;
  632. end;
  633. function taddnode.det_resulttype:tnode;
  634. var
  635. hp : tnode;
  636. lt,rt : tnodetype;
  637. rd,ld : tdef;
  638. htype : ttype;
  639. ot : tnodetype;
  640. hsym : tfieldvarsym;
  641. i : longint;
  642. strtype : tstringtype;
  643. b : boolean;
  644. {$ifdef state_tracking}
  645. factval : Tnode;
  646. change : boolean;
  647. {$endif}
  648. begin
  649. result:=nil;
  650. { first do the two subtrees }
  651. resulttypepass(left);
  652. resulttypepass(right);
  653. { both left and right need to be valid }
  654. set_varstate(left,vs_read,[vsf_must_be_valid]);
  655. set_varstate(right,vs_read,[vsf_must_be_valid]);
  656. if codegenerror then
  657. exit;
  658. { tp procvar support }
  659. maybe_call_procvar(left,true);
  660. maybe_call_procvar(right,true);
  661. { convert array constructors to sets, because there is no other operator
  662. possible for array constructors }
  663. if is_array_constructor(left.resulttype.def) then
  664. begin
  665. arrayconstructor_to_set(left);
  666. resulttypepass(left);
  667. end;
  668. if is_array_constructor(right.resulttype.def) then
  669. begin
  670. arrayconstructor_to_set(right);
  671. resulttypepass(right);
  672. end;
  673. { allow operator overloading }
  674. hp:=self;
  675. if isbinaryoverloaded(hp) then
  676. begin
  677. result:=hp;
  678. exit;
  679. end;
  680. { Stop checking when an error was found in the operator checking }
  681. if codegenerror then
  682. begin
  683. result:=cerrornode.create;
  684. exit;
  685. end;
  686. { Kylix allows enum+ordconstn in an enum declaration (blocktype
  687. is bt_type), we need to do the conversion here before the
  688. constant folding }
  689. if (m_delphi in aktmodeswitches) and
  690. (blocktype=bt_type) then
  691. begin
  692. if (left.resulttype.def.deftype=enumdef) and
  693. (right.resulttype.def.deftype=orddef) then
  694. begin
  695. { insert explicit typecast to default signed int }
  696. left:=ctypeconvnode.create_internal(left,sinttype);
  697. resulttypepass(left);
  698. end
  699. else
  700. if (left.resulttype.def.deftype=orddef) and
  701. (right.resulttype.def.deftype=enumdef) then
  702. begin
  703. { insert explicit typecast to default signed int }
  704. right:=ctypeconvnode.create_internal(right,sinttype);
  705. resulttypepass(right);
  706. end;
  707. end;
  708. result:=simplify;
  709. if assigned(result) then
  710. exit;
  711. { load easier access variables }
  712. rd:=right.resulttype.def;
  713. ld:=left.resulttype.def;
  714. rt:=right.nodetype;
  715. lt:=left.nodetype;
  716. { but an int/int gives real/real! }
  717. if nodetype=slashn then
  718. begin
  719. if is_currency(left.resulttype.def) and
  720. is_currency(right.resulttype.def) then
  721. { In case of currency, converting to float means dividing by 10000 }
  722. { However, since this is already a division, both divisions by }
  723. { 10000 are eliminated when we divide the results -> we can skip }
  724. { them. }
  725. if s64currencytype.def.deftype = floatdef then
  726. begin
  727. { there's no s64comptype or so, how do we avoid the type conversion?
  728. left.resulttype := s64comptype;
  729. right.resulttype := s64comptype; }
  730. end
  731. else
  732. begin
  733. left.resulttype := s64inttype;
  734. right.resulttype := s64inttype;
  735. end
  736. else if (left.resulttype.def.deftype <> floatdef) and
  737. (right.resulttype.def.deftype <> floatdef) then
  738. CGMessage(type_h_use_div_for_int);
  739. inserttypeconv(right,resultrealtype);
  740. inserttypeconv(left,resultrealtype);
  741. end
  742. { if both are orddefs then check sub types }
  743. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  744. begin
  745. { optimize multiplacation by a power of 2 }
  746. if not(cs_check_overflow in aktlocalswitches) and
  747. (nodetype = muln) and
  748. (((left.nodetype = ordconstn) and
  749. ispowerof2(tordconstnode(left).value,i)) or
  750. ((right.nodetype = ordconstn) and
  751. ispowerof2(tordconstnode(right).value,i))) then
  752. begin
  753. if left.nodetype = ordconstn then
  754. begin
  755. tordconstnode(left).value := i;
  756. result := cshlshrnode.create(shln,right,left);
  757. end
  758. else
  759. begin
  760. tordconstnode(right).value := i;
  761. result := cshlshrnode.create(shln,left,right);
  762. end;
  763. left := nil;
  764. right := nil;
  765. exit;
  766. end;
  767. { set for & and | operations in macpas mode: they only work on }
  768. { booleans, and always short circuit evaluation }
  769. if (nf_short_bool in flags) then
  770. begin
  771. if not is_boolean(ld) then
  772. begin
  773. inserttypeconv(left,booltype);
  774. ld := left.resulttype.def;
  775. end;
  776. if not is_boolean(rd) then
  777. begin
  778. inserttypeconv(right,booltype);
  779. rd := right.resulttype.def;
  780. end;
  781. end;
  782. { 2 booleans? Make them equal to the largest boolean }
  783. if (is_boolean(ld) and is_boolean(rd)) or
  784. (nf_short_bool in flags) then
  785. begin
  786. if torddef(left.resulttype.def).size>torddef(right.resulttype.def).size then
  787. begin
  788. right:=ctypeconvnode.create_internal(right,left.resulttype);
  789. ttypeconvnode(right).convtype:=tc_bool_2_bool;
  790. resulttypepass(right);
  791. end
  792. else if torddef(left.resulttype.def).size<torddef(right.resulttype.def).size then
  793. begin
  794. left:=ctypeconvnode.create_internal(left,right.resulttype);
  795. ttypeconvnode(left).convtype:=tc_bool_2_bool;
  796. resulttypepass(left);
  797. end;
  798. case nodetype of
  799. xorn,
  800. ltn,
  801. lten,
  802. gtn,
  803. gten,
  804. andn,
  805. orn:
  806. begin
  807. end;
  808. unequaln,
  809. equaln:
  810. begin
  811. if not(cs_full_boolean_eval in aktlocalswitches) or
  812. (nf_short_bool in flags) then
  813. begin
  814. { Remove any compares with constants }
  815. if (left.nodetype=ordconstn) then
  816. begin
  817. hp:=right;
  818. b:=(tordconstnode(left).value<>0);
  819. ot:=nodetype;
  820. left.free;
  821. left:=nil;
  822. right:=nil;
  823. if (not(b) and (ot=equaln)) or
  824. (b and (ot=unequaln)) then
  825. begin
  826. hp:=cnotnode.create(hp);
  827. end;
  828. result:=hp;
  829. exit;
  830. end;
  831. if (right.nodetype=ordconstn) then
  832. begin
  833. hp:=left;
  834. b:=(tordconstnode(right).value<>0);
  835. ot:=nodetype;
  836. right.free;
  837. right:=nil;
  838. left:=nil;
  839. if (not(b) and (ot=equaln)) or
  840. (b and (ot=unequaln)) then
  841. begin
  842. hp:=cnotnode.create(hp);
  843. end;
  844. result:=hp;
  845. exit;
  846. end;
  847. end;
  848. end;
  849. else
  850. begin
  851. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  852. result:=cnothingnode.create;
  853. exit;
  854. end;
  855. end;
  856. end
  857. { Both are chars? }
  858. else if is_char(rd) and is_char(ld) then
  859. begin
  860. if nodetype=addn then
  861. begin
  862. resulttype:=cshortstringtype;
  863. if not(is_constcharnode(left) and is_constcharnode(right)) then
  864. begin
  865. inserttypeconv(left,cshortstringtype);
  866. {$ifdef addstringopt}
  867. hp := genaddsstringcharoptnode(self);
  868. result := hp;
  869. exit;
  870. {$endif addstringopt}
  871. end;
  872. end;
  873. end
  874. { There is a widechar? }
  875. else if is_widechar(rd) or is_widechar(ld) then
  876. begin
  877. { widechar+widechar gives widestring }
  878. if nodetype=addn then
  879. begin
  880. inserttypeconv(left,cwidestringtype);
  881. if (torddef(rd).typ<>uwidechar) then
  882. inserttypeconv(right,cwidechartype);
  883. resulttype:=cwidestringtype;
  884. end
  885. else
  886. begin
  887. if (torddef(ld).typ<>uwidechar) then
  888. inserttypeconv(left,cwidechartype);
  889. if (torddef(rd).typ<>uwidechar) then
  890. inserttypeconv(right,cwidechartype);
  891. end;
  892. end
  893. { is there a currency type ? }
  894. else if ((torddef(rd).typ=scurrency) or (torddef(ld).typ=scurrency)) then
  895. begin
  896. if (torddef(ld).typ<>scurrency) then
  897. inserttypeconv(left,s64currencytype);
  898. if (torddef(rd).typ<>scurrency) then
  899. inserttypeconv(right,s64currencytype);
  900. end
  901. { and,or,xor work on bit patterns and don't care
  902. about the sign of integers }
  903. { compares don't need extension to native int size either }
  904. { as long as both values are signed or unsigned }
  905. else if is_integer(ld) and is_integer(rd) and
  906. ((nodetype in [andn,orn,xorn]) or
  907. ((nodetype in [equaln,unequaln,gtn,gten,ltn,lten]) and
  908. not(is_signed(ld) xor is_signed(rd)))) then
  909. begin
  910. if rd.size>ld.size then
  911. inserttypeconv_internal(left,right.resulttype)
  912. else
  913. inserttypeconv_internal(right,left.resulttype);
  914. end
  915. { is there a signed 64 bit type ? }
  916. else if ((torddef(rd).typ=s64bit) or (torddef(ld).typ=s64bit)) then
  917. begin
  918. if (torddef(ld).typ<>s64bit) then
  919. inserttypeconv(left,s64inttype);
  920. if (torddef(rd).typ<>s64bit) then
  921. inserttypeconv(right,s64inttype);
  922. end
  923. { is there a unsigned 64 bit type ? }
  924. else if ((torddef(rd).typ=u64bit) or (torddef(ld).typ=u64bit)) then
  925. begin
  926. if (torddef(ld).typ<>u64bit) then
  927. inserttypeconv(left,u64inttype);
  928. if (torddef(rd).typ<>u64bit) then
  929. inserttypeconv(right,u64inttype);
  930. end
  931. { 64 bit cpus do calculations always in 64 bit }
  932. {$ifndef cpu64bit}
  933. { is there a cardinal? }
  934. else if ((torddef(rd).typ=u32bit) or (torddef(ld).typ=u32bit)) then
  935. begin
  936. { convert positive constants to u32bit }
  937. if (torddef(ld).typ<>u32bit) and
  938. is_constintnode(left) and
  939. (tordconstnode(left).value >= 0) then
  940. inserttypeconv(left,u32inttype);
  941. if (torddef(rd).typ<>u32bit) and
  942. is_constintnode(right) and
  943. (tordconstnode(right).value >= 0) then
  944. inserttypeconv(right,u32inttype);
  945. { when one of the operand is signed perform
  946. the operation in 64bit, can't use rd/ld here because there
  947. could be already typeconvs inserted }
  948. if is_signed(left.resulttype.def) or
  949. is_signed(right.resulttype.def) then
  950. begin
  951. CGMessage(type_w_mixed_signed_unsigned);
  952. inserttypeconv(left,s64inttype);
  953. inserttypeconv(right,s64inttype);
  954. end
  955. else
  956. begin
  957. if (torddef(left.resulttype.def).typ<>u32bit) then
  958. inserttypeconv(left,u32inttype);
  959. if (torddef(right.resulttype.def).typ<>u32bit) then
  960. inserttypeconv(right,u32inttype);
  961. end;
  962. end
  963. {$endif cpu64bit}
  964. { generic ord conversion is sinttype }
  965. else
  966. begin
  967. { if the left or right value is smaller than the normal
  968. type sinttype and is unsigned, and the other value
  969. is a constant < 0, the result will always be false/true
  970. for equal / unequal nodes.
  971. }
  972. if (
  973. { left : unsigned ordinal var, right : < 0 constant }
  974. (
  975. ((is_signed(ld)=false) and (is_constintnode(left) =false)) and
  976. ((is_constintnode(right)) and (tordconstnode(right).value < 0))
  977. ) or
  978. { right : unsigned ordinal var, left : < 0 constant }
  979. (
  980. ((is_signed(rd)=false) and (is_constintnode(right) =false)) and
  981. ((is_constintnode(left)) and (tordconstnode(left).value < 0))
  982. )
  983. ) then
  984. begin
  985. if nodetype = equaln then
  986. CGMessage(type_w_signed_unsigned_always_false)
  987. else
  988. if nodetype = unequaln then
  989. CGMessage(type_w_signed_unsigned_always_true)
  990. else
  991. if (is_constintnode(left) and (nodetype in [ltn,lten])) or
  992. (is_constintnode(right) and (nodetype in [gtn,gten])) then
  993. CGMessage(type_w_signed_unsigned_always_true)
  994. else
  995. if (is_constintnode(right) and (nodetype in [ltn,lten])) or
  996. (is_constintnode(left) and (nodetype in [gtn,gten])) then
  997. CGMessage(type_w_signed_unsigned_always_false);
  998. end;
  999. { When there is a signed type or there is a minus operation
  1000. we convert to signed int. Otherwise (both are unsigned) we keep
  1001. the result also unsigned. This is compatible with Delphi (PFV) }
  1002. if is_signed(ld) or
  1003. is_signed(rd) or
  1004. (nodetype=subn) then
  1005. begin
  1006. inserttypeconv(right,sinttype);
  1007. inserttypeconv(left,sinttype);
  1008. end
  1009. else
  1010. begin
  1011. inserttypeconv(right,uinttype);
  1012. inserttypeconv(left,uinttype);
  1013. end;
  1014. end;
  1015. end
  1016. { if both are floatdefs, conversion is already done before constant folding }
  1017. else if (ld.deftype=floatdef) then
  1018. begin
  1019. if not(nodetype in [addn,subn,muln,slashn,equaln,unequaln,ltn,lten,gtn,gten]) then
  1020. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1021. end
  1022. { left side a setdef, must be before string processing,
  1023. else array constructor can be seen as array of char (PFV) }
  1024. else if (ld.deftype=setdef) then
  1025. begin
  1026. { trying to add a set element? }
  1027. if (nodetype=addn) and (rd.deftype<>setdef) then
  1028. begin
  1029. if (rt=setelementn) then
  1030. begin
  1031. if not(equal_defs(tsetdef(ld).elementtype.def,rd)) then
  1032. CGMessage(type_e_set_element_are_not_comp);
  1033. end
  1034. else
  1035. CGMessage(type_e_mismatch)
  1036. end
  1037. else
  1038. begin
  1039. if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
  1040. CGMessage(type_e_set_operation_unknown);
  1041. { right def must be a also be set }
  1042. if (rd.deftype<>setdef) or not(equal_defs(rd,ld)) then
  1043. CGMessage(type_e_set_element_are_not_comp);
  1044. end;
  1045. { ranges require normsets }
  1046. if (tsetdef(ld).settype=smallset) and
  1047. (rt=setelementn) and
  1048. assigned(tsetelementnode(right).right) then
  1049. begin
  1050. { generate a temporary normset def, it'll be destroyed
  1051. when the symtable is unloaded }
  1052. htype.setdef(tsetdef.create(tsetdef(ld).elementtype,255));
  1053. inserttypeconv(left,htype);
  1054. end;
  1055. { if the right side is also a setdef then the settype must
  1056. be the same as the left setdef }
  1057. if (rd.deftype=setdef) and
  1058. (tsetdef(ld).settype<>tsetdef(rd).settype) then
  1059. begin
  1060. { when right is a normset we need to typecast both
  1061. to normsets }
  1062. if (tsetdef(rd).settype=normset) then
  1063. inserttypeconv(left,right.resulttype)
  1064. else
  1065. inserttypeconv(right,left.resulttype);
  1066. end;
  1067. end
  1068. { pointer comparision and subtraction }
  1069. else if (
  1070. (rd.deftype=pointerdef) and (ld.deftype=pointerdef)
  1071. ) or
  1072. { compare/add pchar to variable (not stringconst) char arrays
  1073. by addresses like BP/Delphi }
  1074. (
  1075. (nodetype in [equaln,unequaln,subn,addn]) and
  1076. (
  1077. ((is_pchar(ld) or (lt=niln)) and is_chararray(rd) and (rt<>stringconstn)) or
  1078. ((is_pchar(rd) or (rt=niln)) and is_chararray(ld) and (lt<>stringconstn))
  1079. )
  1080. ) then
  1081. begin
  1082. { convert char array to pointer }
  1083. if is_chararray(rd) then
  1084. begin
  1085. inserttypeconv(right,charpointertype);
  1086. rd:=right.resulttype.def;
  1087. end
  1088. else if is_chararray(ld) then
  1089. begin
  1090. inserttypeconv(left,charpointertype);
  1091. ld:=left.resulttype.def;
  1092. end;
  1093. case nodetype of
  1094. equaln,unequaln :
  1095. begin
  1096. if is_voidpointer(right.resulttype.def) then
  1097. inserttypeconv(right,left.resulttype)
  1098. else if is_voidpointer(left.resulttype.def) then
  1099. inserttypeconv(left,right.resulttype)
  1100. else if not(equal_defs(ld,rd)) then
  1101. IncompatibleTypes(ld,rd);
  1102. { now that the type checking is done, convert both to charpointer, }
  1103. { because methodpointers are 8 bytes even though only the first 4 }
  1104. { bytes must be compared. This can happen here if we are in }
  1105. { TP/Delphi mode, because there @methodpointer = voidpointer (but }
  1106. { a voidpointer of 8 bytes). A conversion to voidpointer would be }
  1107. { optimized away, since the result already was a voidpointer, so }
  1108. { use a charpointer instead (JM) }
  1109. inserttypeconv_internal(left,charpointertype);
  1110. inserttypeconv_internal(right,charpointertype);
  1111. end;
  1112. ltn,lten,gtn,gten:
  1113. begin
  1114. if (cs_extsyntax in aktmoduleswitches) then
  1115. begin
  1116. if is_voidpointer(right.resulttype.def) then
  1117. inserttypeconv(right,left.resulttype)
  1118. else if is_voidpointer(left.resulttype.def) then
  1119. inserttypeconv(left,right.resulttype)
  1120. else if not(equal_defs(ld,rd)) then
  1121. IncompatibleTypes(ld,rd);
  1122. end
  1123. else
  1124. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1125. end;
  1126. subn:
  1127. begin
  1128. if (cs_extsyntax in aktmoduleswitches) then
  1129. begin
  1130. if is_voidpointer(right.resulttype.def) then
  1131. inserttypeconv(right,left.resulttype)
  1132. else if is_voidpointer(left.resulttype.def) then
  1133. inserttypeconv(left,right.resulttype)
  1134. else if not(equal_defs(ld,rd)) then
  1135. IncompatibleTypes(ld,rd);
  1136. end
  1137. else
  1138. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1139. if not(nf_has_pointerdiv in flags) and
  1140. (tpointerdef(rd).pointertype.def.size>1) then
  1141. begin
  1142. hp:=getcopy;
  1143. include(hp.flags,nf_has_pointerdiv);
  1144. result:=cmoddivnode.create(divn,hp,cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,false));
  1145. end;
  1146. resulttype:=sinttype;
  1147. exit;
  1148. end;
  1149. addn:
  1150. begin
  1151. if (cs_extsyntax in aktmoduleswitches) then
  1152. begin
  1153. if is_voidpointer(right.resulttype.def) then
  1154. inserttypeconv(right,left.resulttype)
  1155. else if is_voidpointer(left.resulttype.def) then
  1156. inserttypeconv(left,right.resulttype)
  1157. else if not(equal_defs(ld,rd)) then
  1158. IncompatibleTypes(ld,rd);
  1159. end
  1160. else
  1161. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1162. resulttype:=sinttype;
  1163. exit;
  1164. end;
  1165. else
  1166. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1167. end;
  1168. end
  1169. { is one of the operands a string?,
  1170. chararrays are also handled as strings (after conversion), also take
  1171. care of chararray+chararray and chararray+char.
  1172. Note: Must be done after pointerdef+pointerdef has been checked, else
  1173. pchar is converted to string }
  1174. else if (rd.deftype=stringdef) or
  1175. (ld.deftype=stringdef) or
  1176. ((is_pchar(rd) or is_chararray(rd) or is_char(rd) or is_open_chararray(rd) or
  1177. is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd)) and
  1178. (is_pchar(ld) or is_chararray(ld) or is_char(ld) or is_open_chararray(ld) or
  1179. is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld))) then
  1180. begin
  1181. if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
  1182. begin
  1183. { Is there a widestring? }
  1184. if is_widestring(rd) or is_widestring(ld) or
  1185. is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd) or
  1186. is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld) then
  1187. strtype:= st_widestring
  1188. else
  1189. if is_ansistring(rd) or is_ansistring(ld) or
  1190. ((cs_ansistrings in aktlocalswitches) and
  1191. //todo: Move some of this to longstring's then they are implemented?
  1192. (
  1193. is_pchar(rd) or (is_chararray(rd) and (rd.size > 255)) or is_open_chararray(rd) or
  1194. is_pchar(ld) or (is_chararray(ld) and (ld.size > 255)) or is_open_chararray(ld)
  1195. )
  1196. ) then
  1197. strtype:= st_ansistring
  1198. else
  1199. if is_longstring(rd) or is_longstring(ld) then
  1200. strtype:= st_longstring
  1201. else
  1202. begin
  1203. {$warning todo: add a warning/hint here if one converting a too large array}
  1204. { nodes is PChar, array [with size > 255] or OpenArrayOfChar.
  1205. Note: Delphi halts with error if "array [0..xx] of char"
  1206. is assigned to ShortString and string length is less
  1207. then array size }
  1208. strtype:= st_shortstring;
  1209. end;
  1210. // Now convert nodes to common string type
  1211. case strtype of
  1212. st_widestring :
  1213. begin
  1214. if not(is_widestring(rd)) then
  1215. inserttypeconv(right,cwidestringtype);
  1216. if not(is_widestring(ld)) then
  1217. inserttypeconv(left,cwidestringtype);
  1218. end;
  1219. st_ansistring :
  1220. begin
  1221. if not(is_ansistring(rd)) then
  1222. inserttypeconv(right,cansistringtype);
  1223. if not(is_ansistring(ld)) then
  1224. inserttypeconv(left,cansistringtype);
  1225. end;
  1226. st_longstring :
  1227. begin
  1228. if not(is_longstring(rd)) then
  1229. inserttypeconv(right,clongstringtype);
  1230. if not(is_longstring(ld)) then
  1231. inserttypeconv(left,clongstringtype);
  1232. end;
  1233. st_shortstring :
  1234. begin
  1235. if not(is_shortstring(ld)) then
  1236. inserttypeconv(left,cshortstringtype);
  1237. { don't convert char, that can be handled by the optimized node }
  1238. if not(is_shortstring(rd) or is_char(rd)) then
  1239. inserttypeconv(right,cshortstringtype);
  1240. end;
  1241. else
  1242. internalerror(2005101);
  1243. end;
  1244. end
  1245. else
  1246. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1247. end
  1248. { class or interface equation }
  1249. else if is_class_or_interface(rd) or is_class_or_interface(ld) then
  1250. begin
  1251. if (nodetype in [equaln,unequaln]) then
  1252. begin
  1253. if is_class_or_interface(rd) and is_class_or_interface(ld) then
  1254. begin
  1255. if tobjectdef(rd).is_related(tobjectdef(ld)) then
  1256. inserttypeconv(right,left.resulttype)
  1257. else
  1258. inserttypeconv(left,right.resulttype);
  1259. end
  1260. else if is_class_or_interface(rd) then
  1261. inserttypeconv(left,right.resulttype)
  1262. else
  1263. inserttypeconv(right,left.resulttype);
  1264. end
  1265. else
  1266. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1267. end
  1268. else if (rd.deftype=classrefdef) and (ld.deftype=classrefdef) then
  1269. begin
  1270. if (nodetype in [equaln,unequaln]) then
  1271. begin
  1272. if tobjectdef(tclassrefdef(rd).pointertype.def).is_related(
  1273. tobjectdef(tclassrefdef(ld).pointertype.def)) then
  1274. inserttypeconv(right,left.resulttype)
  1275. else
  1276. inserttypeconv(left,right.resulttype);
  1277. end
  1278. else
  1279. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1280. end
  1281. { allows comperasion with nil pointer }
  1282. else if is_class_or_interface(rd) or (rd.deftype=classrefdef) then
  1283. begin
  1284. if (nodetype in [equaln,unequaln]) then
  1285. inserttypeconv(left,right.resulttype)
  1286. else
  1287. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1288. end
  1289. else if is_class_or_interface(ld) or (ld.deftype=classrefdef) then
  1290. begin
  1291. if (nodetype in [equaln,unequaln]) then
  1292. inserttypeconv(right,left.resulttype)
  1293. else
  1294. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1295. end
  1296. { support procvar=nil,procvar<>nil }
  1297. else if ((ld.deftype=procvardef) and (rt=niln)) or
  1298. ((rd.deftype=procvardef) and (lt=niln)) then
  1299. begin
  1300. if not(nodetype in [equaln,unequaln]) then
  1301. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1302. { find proc field in methodpointer record }
  1303. hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
  1304. if not assigned(hsym) then
  1305. internalerror(200412043);
  1306. { For methodpointers compare only tmethodpointer.proc }
  1307. if (rd.deftype=procvardef) and
  1308. (not tprocvardef(rd).is_addressonly) then
  1309. begin
  1310. right:=csubscriptnode.create(
  1311. hsym,
  1312. ctypeconvnode.create_internal(right,methodpointertype));
  1313. end;
  1314. if (ld.deftype=procvardef) and
  1315. (not tprocvardef(ld).is_addressonly) then
  1316. begin
  1317. left:=csubscriptnode.create(
  1318. hsym,
  1319. ctypeconvnode.create_internal(left,methodpointertype));
  1320. end;
  1321. end
  1322. { support dynamicarray=nil,dynamicarray<>nil }
  1323. else if (is_dynamic_array(ld) and (rt=niln)) or
  1324. (is_dynamic_array(rd) and (lt=niln)) or
  1325. (is_dynamic_array(ld) and is_dynamic_array(rd)) then
  1326. begin
  1327. if not(nodetype in [equaln,unequaln]) then
  1328. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1329. end
  1330. {$ifdef SUPPORT_MMX}
  1331. { mmx support, this must be before the zero based array
  1332. check }
  1333. else if (cs_mmx in aktlocalswitches) and
  1334. is_mmx_able_array(ld) and
  1335. is_mmx_able_array(rd) and
  1336. equal_defs(ld,rd) then
  1337. begin
  1338. case nodetype of
  1339. addn,subn,xorn,orn,andn:
  1340. ;
  1341. { mul is a little bit restricted }
  1342. muln:
  1343. if not(mmx_type(ld) in [mmxu16bit,mmxs16bit,mmxfixed16]) then
  1344. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1345. else
  1346. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1347. end;
  1348. end
  1349. {$endif SUPPORT_MMX}
  1350. { this is a little bit dangerous, also the left type }
  1351. { pointer to should be checked! This broke the mmx support }
  1352. else if (rd.deftype=pointerdef) or
  1353. (is_zero_based_array(rd) and (rt<>stringconstn)) then
  1354. begin
  1355. if is_zero_based_array(rd) then
  1356. begin
  1357. resulttype.setdef(tpointerdef.create(tarraydef(rd).elementtype));
  1358. inserttypeconv(right,resulttype);
  1359. end
  1360. else
  1361. resulttype:=right.resulttype;
  1362. inserttypeconv(left,sinttype);
  1363. if nodetype=addn then
  1364. begin
  1365. if not(cs_extsyntax in aktmoduleswitches) or
  1366. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1367. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1368. if (rd.deftype=pointerdef) and
  1369. (tpointerdef(rd).pointertype.def.size>1) then
  1370. begin
  1371. left:=caddnode.create(muln,left,
  1372. cordconstnode.create(tpointerdef(rd).pointertype.def.size,sinttype,true));
  1373. end;
  1374. end
  1375. else
  1376. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1377. end
  1378. else if (ld.deftype=pointerdef) or
  1379. (is_zero_based_array(ld) and (lt<>stringconstn)) then
  1380. begin
  1381. if is_zero_based_array(ld) then
  1382. begin
  1383. resulttype.setdef(tpointerdef.create(tarraydef(ld).elementtype));
  1384. inserttypeconv(left,resulttype);
  1385. end
  1386. else
  1387. resulttype:=left.resulttype;
  1388. inserttypeconv(right,sinttype);
  1389. if nodetype in [addn,subn] then
  1390. begin
  1391. if not(cs_extsyntax in aktmoduleswitches) or
  1392. (not(is_pchar(ld)) and not(m_add_pointer in aktmodeswitches)) then
  1393. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1394. if (ld.deftype=pointerdef) and
  1395. (tpointerdef(ld).pointertype.def.size>1) then
  1396. begin
  1397. right:=caddnode.create(muln,right,
  1398. cordconstnode.create(tpointerdef(ld).pointertype.def.size,sinttype,true));
  1399. end
  1400. else
  1401. if is_zero_based_array(ld) and
  1402. (tarraydef(ld).elementtype.def.size>1) then
  1403. begin
  1404. right:=caddnode.create(muln,right,
  1405. cordconstnode.create(tarraydef(ld).elementtype.def.size,sinttype,true));
  1406. end;
  1407. end
  1408. else
  1409. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1410. end
  1411. else if (rd.deftype=procvardef) and
  1412. (ld.deftype=procvardef) and
  1413. equal_defs(rd,ld) then
  1414. begin
  1415. if (nodetype in [equaln,unequaln]) then
  1416. begin
  1417. if tprocvardef(rd).is_addressonly then
  1418. begin
  1419. inserttypeconv_internal(right,voidpointertype);
  1420. inserttypeconv_internal(left,voidpointertype);
  1421. end
  1422. else
  1423. begin
  1424. { find proc field in methodpointer record }
  1425. hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
  1426. if not assigned(hsym) then
  1427. internalerror(200412043);
  1428. { Compare tmehodpointer(left).proc }
  1429. right:=csubscriptnode.create(
  1430. hsym,
  1431. ctypeconvnode.create_internal(right,methodpointertype));
  1432. left:=csubscriptnode.create(
  1433. hsym,
  1434. ctypeconvnode.create_internal(left,methodpointertype));
  1435. end;
  1436. end
  1437. else
  1438. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1439. end
  1440. { enums }
  1441. else if (ld.deftype=enumdef) and (rd.deftype=enumdef) then
  1442. begin
  1443. if allowenumop(nodetype) then
  1444. inserttypeconv(right,left.resulttype)
  1445. else
  1446. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);
  1447. end
  1448. { generic conversion, this is for error recovery }
  1449. else
  1450. begin
  1451. inserttypeconv(left,sinttype);
  1452. inserttypeconv(right,sinttype);
  1453. end;
  1454. { set resulttype if not already done }
  1455. if not assigned(resulttype.def) then
  1456. begin
  1457. case nodetype of
  1458. ltn,lten,gtn,gten,equaln,unequaln :
  1459. resulttype:=booltype;
  1460. slashn :
  1461. resulttype:=resultrealtype;
  1462. addn:
  1463. begin
  1464. { for strings, return is always a 255 char string }
  1465. if is_shortstring(left.resulttype.def) then
  1466. resulttype:=cshortstringtype
  1467. else
  1468. resulttype:=left.resulttype;
  1469. end;
  1470. else
  1471. resulttype:=left.resulttype;
  1472. end;
  1473. end;
  1474. { when the result is currency we need some extra code for
  1475. multiplication and division. this should not be done when
  1476. the muln or slashn node is created internally }
  1477. if not(nf_is_currency in flags) and
  1478. is_currency(resulttype.def) then
  1479. begin
  1480. case nodetype of
  1481. slashn :
  1482. begin
  1483. { slashn will only work with floats }
  1484. hp:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,s64currencytype));
  1485. include(hp.flags,nf_is_currency);
  1486. result:=hp;
  1487. end;
  1488. muln :
  1489. begin
  1490. if s64currencytype.def.deftype=floatdef then
  1491. hp:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,s64currencytype))
  1492. else
  1493. hp:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,s64currencytype,false));
  1494. include(hp.flags,nf_is_currency);
  1495. result:=hp
  1496. end;
  1497. end;
  1498. end;
  1499. end;
  1500. function taddnode.first_addstring: tnode;
  1501. const
  1502. swap_relation: array [ltn..unequaln] of Tnodetype=(gtn, gten, ltn, lten, equaln, unequaln);
  1503. var
  1504. p: tnode;
  1505. begin
  1506. { when we get here, we are sure that both the left and the right }
  1507. { node are both strings of the same stringtype (JM) }
  1508. case nodetype of
  1509. addn:
  1510. begin
  1511. if (left.nodetype=stringconstn) and (tstringconstnode(left).len=0) then
  1512. begin
  1513. result:=right;
  1514. left:=nil;
  1515. right:=nil;
  1516. exit;
  1517. end;
  1518. if (right.nodetype=stringconstn) and (tstringconstnode(right).len=0) then
  1519. begin
  1520. result:=left;
  1521. left:=nil;
  1522. right:=nil;
  1523. exit;
  1524. end;
  1525. { create the call to the concat routine both strings as arguments }
  1526. result := ccallnode.createintern('fpc_'+
  1527. tstringdef(resulttype.def).stringtypname+'_concat',
  1528. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1529. { we reused the arguments }
  1530. left := nil;
  1531. right := nil;
  1532. end;
  1533. ltn,lten,gtn,gten,equaln,unequaln :
  1534. begin
  1535. { generate better code for comparison with empty string, we
  1536. only need to compare the length with 0 }
  1537. if (nodetype in [equaln,unequaln,gtn,gten,ltn,lten]) and
  1538. (((left.nodetype=stringconstn) and (tstringconstnode(left).len=0)) or
  1539. ((right.nodetype=stringconstn) and (tstringconstnode(right).len=0))) then
  1540. begin
  1541. { switch so that the constant is always on the right }
  1542. if left.nodetype = stringconstn then
  1543. begin
  1544. p := left;
  1545. left := right;
  1546. right := p;
  1547. nodetype:=swap_relation[nodetype];
  1548. end;
  1549. if is_shortstring(left.resulttype.def) or
  1550. (nodetype in [gtn,gten,ltn,lten]) then
  1551. { compare the length with 0 }
  1552. result := caddnode.create(nodetype,
  1553. cinlinenode.create(in_length_x,false,left),
  1554. cordconstnode.create(0,s32inttype,false))
  1555. else
  1556. begin
  1557. { compare the pointer with nil (for ansistrings etc), }
  1558. { faster than getting the length (JM) }
  1559. result:= caddnode.create(nodetype,
  1560. ctypeconvnode.create_internal(left,voidpointertype),
  1561. cpointerconstnode.create(0,voidpointertype));
  1562. end;
  1563. { left is reused }
  1564. left := nil;
  1565. { right isn't }
  1566. right.free;
  1567. right := nil;
  1568. exit;
  1569. end;
  1570. { no string constant -> call compare routine }
  1571. result := ccallnode.createintern('fpc_'+
  1572. tstringdef(left.resulttype.def).stringtypname+'_compare',
  1573. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1574. { and compare its result with 0 according to the original operator }
  1575. result := caddnode.create(nodetype,result,
  1576. cordconstnode.create(0,s32inttype,false));
  1577. left := nil;
  1578. right := nil;
  1579. end;
  1580. end;
  1581. end;
  1582. function taddnode.first_addset: tnode;
  1583. var
  1584. procname: string[31];
  1585. tempn: tnode;
  1586. paras: tcallparanode;
  1587. srsym: ttypesym;
  1588. begin
  1589. { get the sym that represents the fpc_normal_set type }
  1590. srsym:=search_system_type('FPC_NORMAL_SET');
  1591. case nodetype of
  1592. equaln,unequaln,lten,gten:
  1593. begin
  1594. case nodetype of
  1595. equaln,unequaln:
  1596. procname := 'fpc_set_comp_sets';
  1597. lten,gten:
  1598. begin
  1599. procname := 'fpc_set_contains_sets';
  1600. { (left >= right) = (right <= left) }
  1601. if nodetype = gten then
  1602. begin
  1603. tempn := left;
  1604. left := right;
  1605. right := tempn;
  1606. end;
  1607. end;
  1608. end;
  1609. { convert the arguments (explicitely) to fpc_normal_set's }
  1610. left := ctypeconvnode.create_internal(left,srsym.restype);
  1611. right := ctypeconvnode.create_internal(right,srsym.restype);
  1612. result := ccallnode.createintern(procname,ccallparanode.create(right,
  1613. ccallparanode.create(left,nil)));
  1614. { left and right are reused as parameters }
  1615. left := nil;
  1616. right := nil;
  1617. { for an unequaln, we have to negate the result of comp_sets }
  1618. if nodetype = unequaln then
  1619. result := cnotnode.create(result);
  1620. end;
  1621. addn:
  1622. begin
  1623. { optimize first loading of a set }
  1624. if (right.nodetype=setelementn) and
  1625. not(assigned(tsetelementnode(right).right)) and
  1626. is_emptyset(left) then
  1627. begin
  1628. { type cast the value to pass as argument to a byte, }
  1629. { since that's what the helper expects }
  1630. tsetelementnode(right).left :=
  1631. ctypeconvnode.create_internal(tsetelementnode(right).left,u8inttype);
  1632. { set the resulttype to the actual one (otherwise it's }
  1633. { "fpc_normal_set") }
  1634. result := ccallnode.createinternres('fpc_set_create_element',
  1635. ccallparanode.create(tsetelementnode(right).left,nil),
  1636. resulttype);
  1637. { reused }
  1638. tsetelementnode(right).left := nil;
  1639. end
  1640. else
  1641. begin
  1642. if right.nodetype=setelementn then
  1643. begin
  1644. { convert the arguments to bytes, since that's what }
  1645. { the helper expects }
  1646. tsetelementnode(right).left :=
  1647. ctypeconvnode.create_internal(tsetelementnode(right).left,
  1648. u8inttype);
  1649. { convert the original set (explicitely) to an }
  1650. { fpc_normal_set so we can pass it to the helper }
  1651. left := ctypeconvnode.create_internal(left,srsym.restype);
  1652. { add a range or a single element? }
  1653. if assigned(tsetelementnode(right).right) then
  1654. begin
  1655. tsetelementnode(right).right :=
  1656. ctypeconvnode.create_internal(tsetelementnode(right).right,
  1657. u8inttype);
  1658. { create the call }
  1659. result := ccallnode.createinternres('fpc_set_set_range',
  1660. ccallparanode.create(tsetelementnode(right).right,
  1661. ccallparanode.create(tsetelementnode(right).left,
  1662. ccallparanode.create(left,nil))),resulttype);
  1663. end
  1664. else
  1665. begin
  1666. result := ccallnode.createinternres('fpc_set_set_byte',
  1667. ccallparanode.create(tsetelementnode(right).left,
  1668. ccallparanode.create(left,nil)),resulttype);
  1669. end;
  1670. { remove reused parts from original node }
  1671. tsetelementnode(right).right := nil;
  1672. tsetelementnode(right).left := nil;
  1673. left := nil;
  1674. end
  1675. else
  1676. begin
  1677. { add two sets }
  1678. { convert the sets to fpc_normal_set's }
  1679. result := ccallnode.createinternres('fpc_set_add_sets',
  1680. ccallparanode.create(
  1681. ctypeconvnode.create_explicit(right,srsym.restype),
  1682. ccallparanode.create(
  1683. ctypeconvnode.create_internal(left,srsym.restype),nil)),resulttype);
  1684. { remove reused parts from original node }
  1685. left := nil;
  1686. right := nil;
  1687. end;
  1688. end
  1689. end;
  1690. subn,symdifn,muln:
  1691. begin
  1692. { convert the sets to fpc_normal_set's }
  1693. paras := ccallparanode.create(ctypeconvnode.create_internal(right,srsym.restype),
  1694. ccallparanode.create(ctypeconvnode.create_internal(left,srsym.restype),nil));
  1695. case nodetype of
  1696. subn:
  1697. result := ccallnode.createinternres('fpc_set_sub_sets',
  1698. paras,resulttype);
  1699. symdifn:
  1700. result := ccallnode.createinternres('fpc_set_symdif_sets',
  1701. paras,resulttype);
  1702. muln:
  1703. result := ccallnode.createinternres('fpc_set_mul_sets',
  1704. paras,resulttype);
  1705. end;
  1706. { remove reused parts from original node }
  1707. left := nil;
  1708. right := nil;
  1709. end;
  1710. else
  1711. internalerror(200108311);
  1712. end;
  1713. end;
  1714. function taddnode.use_generic_mul32to64: boolean;
  1715. begin
  1716. result := true;
  1717. end;
  1718. function taddnode.try_make_mul32to64: boolean;
  1719. function canbe32bitint(v: tconstexprint; fromdef: torddef; todefsigned: boolean): boolean;
  1720. begin
  1721. if (fromdef.typ <> u64bit) then
  1722. result :=
  1723. ((v >= 0) or
  1724. todefsigned) and
  1725. (v >= low(longint)) and
  1726. (v <= high(longint))
  1727. else
  1728. result :=
  1729. (qword(v) >= low(cardinal)) and
  1730. (qword(v) <= high(cardinal))
  1731. end;
  1732. var
  1733. temp: tnode;
  1734. begin
  1735. result := false;
  1736. if ((left.nodetype = typeconvn) and
  1737. is_integer(ttypeconvnode(left).left.resulttype.def) and
  1738. (not(torddef(ttypeconvnode(left).left.resulttype.def).typ in [u64bit,s64bit])) and
  1739. (((right.nodetype = ordconstn) and
  1740. canbe32bitint(tordconstnode(right).value,torddef(right.resulttype.def),is_signed(left.resulttype.def))) or
  1741. ((right.nodetype = typeconvn) and
  1742. is_integer(ttypeconvnode(right).left.resulttype.def) and
  1743. not(torddef(ttypeconvnode(right).left.resulttype.def).typ in [u64bit,s64bit])) and
  1744. (is_signed(ttypeconvnode(left).left.resulttype.def) =
  1745. is_signed(ttypeconvnode(right).left.resulttype.def)))) then
  1746. begin
  1747. temp := ttypeconvnode(left).left;
  1748. ttypeconvnode(left).left := nil;
  1749. left.free;
  1750. left := temp;
  1751. if (right.nodetype = typeconvn) then
  1752. begin
  1753. temp := ttypeconvnode(right).left;
  1754. ttypeconvnode(right).left := nil;
  1755. right.free;
  1756. right := temp;
  1757. end;
  1758. if (is_signed(left.resulttype.def)) then
  1759. begin
  1760. inserttypeconv(left,s32inttype);
  1761. inserttypeconv(right,s32inttype);
  1762. end
  1763. else
  1764. begin
  1765. inserttypeconv(left,u32inttype);
  1766. inserttypeconv(right,u32inttype);
  1767. end;
  1768. firstpass(left);
  1769. firstpass(right);
  1770. result := true;
  1771. end;
  1772. end;
  1773. function taddnode.first_add64bitint: tnode;
  1774. var
  1775. procname: string[31];
  1776. temp: tnode;
  1777. power: longint;
  1778. begin
  1779. result := nil;
  1780. { create helper calls mul }
  1781. if nodetype <> muln then
  1782. exit;
  1783. { make sure that if there is a constant, that it's on the right }
  1784. if left.nodetype = ordconstn then
  1785. begin
  1786. temp := right;
  1787. right := left;
  1788. left := temp;
  1789. end;
  1790. { can we use a shift instead of a mul? }
  1791. if not (cs_check_overflow in aktlocalswitches) and
  1792. (right.nodetype = ordconstn) and
  1793. ispowerof2(tordconstnode(right).value,power) then
  1794. begin
  1795. tordconstnode(right).value := power;
  1796. result := cshlshrnode.create(shln,left,right);
  1797. { left and right are reused }
  1798. left := nil;
  1799. right := nil;
  1800. { return firstpassed new node }
  1801. exit;
  1802. end;
  1803. if not(use_generic_mul32to64) and
  1804. try_make_mul32to64 then
  1805. exit;
  1806. { when currency is used set the result of the
  1807. parameters to s64bit, so they are not converted }
  1808. if is_currency(resulttype.def) then
  1809. begin
  1810. left.resulttype:=s64inttype;
  1811. right.resulttype:=s64inttype;
  1812. end;
  1813. { otherwise, create the parameters for the helper }
  1814. right := ccallparanode.create(
  1815. cordconstnode.create(ord(cs_check_overflow in aktlocalswitches),booltype,true),
  1816. ccallparanode.create(right,ccallparanode.create(left,nil)));
  1817. left := nil;
  1818. { only qword needs the unsigned code, the
  1819. signed code is also used for currency }
  1820. if is_signed(resulttype.def) then
  1821. procname := 'fpc_mul_int64'
  1822. else
  1823. procname := 'fpc_mul_qword';
  1824. result := ccallnode.createintern(procname,right);
  1825. right := nil;
  1826. end;
  1827. function taddnode.first_addfloat : tnode;
  1828. var
  1829. procname: string[31];
  1830. { do we need to reverse the result ? }
  1831. notnode : boolean;
  1832. begin
  1833. result := nil;
  1834. notnode := false;
  1835. { In non-emulation mode, real opcodes are
  1836. emitted for floating point values.
  1837. }
  1838. if not (cs_fp_emulation in aktmoduleswitches) then
  1839. exit;
  1840. if not(target_info.system in system_wince) then
  1841. begin
  1842. case tfloatdef(left.resulttype.def).typ of
  1843. s32real:
  1844. procname:='float32';
  1845. s64real:
  1846. procname:='float64';
  1847. {!!! not yet implemented
  1848. s128real:
  1849. }
  1850. else
  1851. internalerror(2005082601);
  1852. end;
  1853. case nodetype of
  1854. addn:
  1855. procname:=procname+'_add';
  1856. muln:
  1857. procname:=procname+'_mul';
  1858. subn:
  1859. procname:=procname+'_sub';
  1860. slashn:
  1861. procname:=procname+'_div';
  1862. ltn:
  1863. procname:=procname+'_lt';
  1864. lten:
  1865. procname:=procname+'_le';
  1866. gtn:
  1867. begin
  1868. procname:=procname+'_le';
  1869. notnode:=true;
  1870. end;
  1871. gten:
  1872. begin
  1873. procname:=procname+'_lt';
  1874. notnode:=true;
  1875. end;
  1876. equaln:
  1877. procname:=procname+'_eq';
  1878. unequaln:
  1879. begin
  1880. procname:=procname+'_eq';
  1881. notnode:=true;
  1882. end;
  1883. else
  1884. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
  1885. end;
  1886. end
  1887. else
  1888. begin
  1889. case nodetype of
  1890. addn:
  1891. procname:='ADD';
  1892. muln:
  1893. procname:='MUL';
  1894. subn:
  1895. procname:='SUB';
  1896. slashn:
  1897. procname:='DIV';
  1898. ltn:
  1899. procname:='LT';
  1900. lten:
  1901. procname:='LE';
  1902. gtn:
  1903. procname:='GT';
  1904. gten:
  1905. procname:='GE';
  1906. equaln:
  1907. procname:='EQ';
  1908. unequaln:
  1909. procname:='NE';
  1910. else
  1911. CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resulttype.def.typename,right.resulttype.def.typename);
  1912. end;
  1913. case tfloatdef(left.resulttype.def).typ of
  1914. s32real:
  1915. procname:=procname+'S';
  1916. s64real:
  1917. procname:=procname+'D';
  1918. {!!! not yet implemented
  1919. s128real:
  1920. }
  1921. else
  1922. internalerror(2005082602);
  1923. end;
  1924. end;
  1925. result:=ccallnode.createintern(procname,ccallparanode.create(right,
  1926. ccallparanode.create(left,nil)));
  1927. left:=nil;
  1928. right:=nil;
  1929. { do we need to reverse the result }
  1930. if notnode then
  1931. result:=cnotnode.create(result);
  1932. end;
  1933. function taddnode.pass_1 : tnode;
  1934. var
  1935. {$ifdef addstringopt}
  1936. hp : tnode;
  1937. {$endif addstringopt}
  1938. lt,rt : tnodetype;
  1939. rd,ld : tdef;
  1940. begin
  1941. result:=nil;
  1942. { Can we optimize multiple string additions into a single call?
  1943. This need to be done on a complete tree to detect the multiple
  1944. add nodes and is therefor done before the subtrees are processed }
  1945. if canbemultistringadd(self) then
  1946. begin
  1947. result := genmultistringadd(self);
  1948. exit;
  1949. end;
  1950. { first do the two subtrees }
  1951. firstpass(left);
  1952. firstpass(right);
  1953. if codegenerror then
  1954. exit;
  1955. { load easier access variables }
  1956. rd:=right.resulttype.def;
  1957. ld:=left.resulttype.def;
  1958. rt:=right.nodetype;
  1959. lt:=left.nodetype;
  1960. { int/int gives real/real! }
  1961. if nodetype=slashn then
  1962. begin
  1963. {$ifdef cpufpemu}
  1964. if (aktfputype=fpu_soft) or (cs_fp_emulation in aktmoduleswitches) then
  1965. begin
  1966. result:=first_addfloat;
  1967. if assigned(result) then
  1968. exit;
  1969. end;
  1970. {$endif cpufpemu}
  1971. expectloc:=LOC_FPUREGISTER;
  1972. { maybe we need an integer register to save }
  1973. { a reference }
  1974. if ((left.expectloc<>LOC_FPUREGISTER) or
  1975. (right.expectloc<>LOC_FPUREGISTER)) and
  1976. (left.registersint=right.registersint) then
  1977. calcregisters(self,1,1,0)
  1978. else
  1979. calcregisters(self,0,1,0);
  1980. { an add node always first loads both the left and the }
  1981. { right in the fpu before doing the calculation. However, }
  1982. { calcregisters(0,2,0) will overestimate the number of }
  1983. { necessary registers (it will make it 3 in case one of }
  1984. { the operands is already in the fpu) (JM) }
  1985. if ((left.expectloc<>LOC_FPUREGISTER) or
  1986. (right.expectloc<>LOC_FPUREGISTER)) and
  1987. (registersfpu < 2) then
  1988. inc(registersfpu);
  1989. end
  1990. { if both are orddefs then check sub types }
  1991. else if (ld.deftype=orddef) and (rd.deftype=orddef) then
  1992. begin
  1993. { 2 booleans ? }
  1994. if is_boolean(ld) and is_boolean(rd) then
  1995. begin
  1996. if (not(cs_full_boolean_eval in aktlocalswitches) or
  1997. (nf_short_bool in flags)) and
  1998. (nodetype in [andn,orn]) then
  1999. begin
  2000. expectloc:=LOC_JUMP;
  2001. calcregisters(self,0,0,0);
  2002. end
  2003. else
  2004. begin
  2005. if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
  2006. begin
  2007. expectloc:=LOC_FLAGS;
  2008. if (left.expectloc in [LOC_JUMP,LOC_FLAGS]) and
  2009. (left.expectloc in [LOC_JUMP,LOC_FLAGS]) then
  2010. calcregisters(self,2,0,0)
  2011. else
  2012. calcregisters(self,1,0,0);
  2013. end
  2014. else
  2015. begin
  2016. expectloc:=LOC_REGISTER;
  2017. calcregisters(self,0,0,0);
  2018. end;
  2019. end;
  2020. end
  2021. else
  2022. { Both are chars? only convert to shortstrings for addn }
  2023. if is_char(ld) then
  2024. begin
  2025. if nodetype=addn then
  2026. internalerror(200103291);
  2027. expectloc:=LOC_FLAGS;
  2028. calcregisters(self,1,0,0);
  2029. end
  2030. {$ifndef cpu64bit}
  2031. { is there a 64 bit type ? }
  2032. else if (torddef(ld).typ in [s64bit,u64bit,scurrency]) then
  2033. begin
  2034. result := first_add64bitint;
  2035. if assigned(result) then
  2036. exit;
  2037. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2038. expectloc:=LOC_REGISTER
  2039. else
  2040. expectloc:=LOC_JUMP;
  2041. calcregisters(self,2,0,0)
  2042. end
  2043. {$endif cpu64bit}
  2044. { is there a cardinal? }
  2045. else if (torddef(ld).typ=u32bit) then
  2046. begin
  2047. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2048. expectloc:=LOC_REGISTER
  2049. else
  2050. expectloc:=LOC_FLAGS;
  2051. calcregisters(self,1,0,0);
  2052. { for unsigned mul we need an extra register }
  2053. if nodetype=muln then
  2054. inc(registersint);
  2055. end
  2056. { generic s32bit conversion }
  2057. else
  2058. begin
  2059. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2060. expectloc:=LOC_REGISTER
  2061. else
  2062. expectloc:=LOC_FLAGS;
  2063. calcregisters(self,1,0,0);
  2064. end;
  2065. end
  2066. { left side a setdef, must be before string processing,
  2067. else array constructor can be seen as array of char (PFV) }
  2068. else if (ld.deftype=setdef) then
  2069. begin
  2070. if tsetdef(ld).settype=smallset then
  2071. begin
  2072. if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
  2073. expectloc:=LOC_FLAGS
  2074. else
  2075. expectloc:=LOC_REGISTER;
  2076. { are we adding set elements ? }
  2077. if right.nodetype=setelementn then
  2078. calcregisters(self,2,0,0)
  2079. else
  2080. calcregisters(self,1,0,0);
  2081. end
  2082. else
  2083. {$ifdef MMXSET}
  2084. {$ifdef i386}
  2085. if cs_mmx in aktlocalswitches then
  2086. begin
  2087. expectloc:=LOC_MMXREGISTER;
  2088. calcregisters(self,0,0,4);
  2089. end
  2090. else
  2091. {$endif}
  2092. {$endif MMXSET}
  2093. begin
  2094. result := first_addset;
  2095. if assigned(result) then
  2096. exit;
  2097. expectloc:=LOC_CREFERENCE;
  2098. calcregisters(self,0,0,0);
  2099. { here we call SET... }
  2100. include(current_procinfo.flags,pi_do_call);
  2101. end;
  2102. end
  2103. { compare pchar by addresses like BP/Delphi }
  2104. else if is_pchar(ld) then
  2105. begin
  2106. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2107. expectloc:=LOC_REGISTER
  2108. else
  2109. expectloc:=LOC_FLAGS;
  2110. calcregisters(self,1,0,0);
  2111. end
  2112. { is one of the operands a string }
  2113. else if (ld.deftype=stringdef) then
  2114. begin
  2115. if is_widestring(ld) then
  2116. begin
  2117. { this is only for add, the comparisaion is handled later }
  2118. expectloc:=LOC_REGISTER;
  2119. end
  2120. else if is_ansistring(ld) then
  2121. begin
  2122. { this is only for add, the comparisaion is handled later }
  2123. expectloc:=LOC_REGISTER;
  2124. end
  2125. else if is_longstring(ld) then
  2126. begin
  2127. { this is only for add, the comparisaion is handled later }
  2128. expectloc:=LOC_REFERENCE;
  2129. end
  2130. else
  2131. begin
  2132. {$ifdef addstringopt}
  2133. { can create a call which isn't handled by callparatemp }
  2134. if canbeaddsstringcharoptnode(self) then
  2135. begin
  2136. hp := genaddsstringcharoptnode(self);
  2137. pass_1 := hp;
  2138. exit;
  2139. end
  2140. else
  2141. {$endif addstringopt}
  2142. begin
  2143. { Fix right to be shortstring }
  2144. if is_char(right.resulttype.def) then
  2145. begin
  2146. inserttypeconv(right,cshortstringtype);
  2147. firstpass(right);
  2148. end;
  2149. end;
  2150. {$ifdef addstringopt}
  2151. { can create a call which isn't handled by callparatemp }
  2152. if canbeaddsstringcsstringoptnode(self) then
  2153. begin
  2154. hp := genaddsstringcsstringoptnode(self);
  2155. pass_1 := hp;
  2156. exit;
  2157. end;
  2158. {$endif addstringopt}
  2159. end;
  2160. { otherwise, let addstring convert everything }
  2161. result := first_addstring;
  2162. exit;
  2163. end
  2164. { is one a real float ? }
  2165. else if (rd.deftype=floatdef) or (ld.deftype=floatdef) then
  2166. begin
  2167. {$ifdef cpufpemu}
  2168. if (aktfputype=fpu_soft) or (cs_fp_emulation in aktmoduleswitches) then
  2169. begin
  2170. result:=first_addfloat;
  2171. if assigned(result) then
  2172. exit;
  2173. end;
  2174. {$endif cpufpemu}
  2175. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2176. expectloc:=LOC_FPUREGISTER
  2177. else
  2178. expectloc:=LOC_FLAGS;
  2179. calcregisters(self,0,1,0);
  2180. { an add node always first loads both the left and the }
  2181. { right in the fpu before doing the calculation. However, }
  2182. { calcregisters(0,2,0) will overestimate the number of }
  2183. { necessary registers (it will make it 3 in case one of }
  2184. { the operands is already in the fpu) (JM) }
  2185. if ((left.expectloc<>LOC_FPUREGISTER) or
  2186. (right.expectloc<>LOC_FPUREGISTER)) and
  2187. (registersfpu < 2) then
  2188. inc(registersfpu);
  2189. end
  2190. { pointer comperation and subtraction }
  2191. else if (ld.deftype=pointerdef) then
  2192. begin
  2193. if nodetype in [addn,subn,muln,andn,orn,xorn] then
  2194. expectloc:=LOC_REGISTER
  2195. else
  2196. expectloc:=LOC_FLAGS;
  2197. calcregisters(self,1,0,0);
  2198. end
  2199. else if is_class_or_interface(ld) then
  2200. begin
  2201. expectloc:=LOC_FLAGS;
  2202. calcregisters(self,1,0,0);
  2203. end
  2204. else if (ld.deftype=classrefdef) then
  2205. begin
  2206. expectloc:=LOC_FLAGS;
  2207. calcregisters(self,1,0,0);
  2208. end
  2209. { support procvar=nil,procvar<>nil }
  2210. else if ((ld.deftype=procvardef) and (rt=niln)) or
  2211. ((rd.deftype=procvardef) and (lt=niln)) then
  2212. begin
  2213. expectloc:=LOC_FLAGS;
  2214. calcregisters(self,1,0,0);
  2215. end
  2216. {$ifdef SUPPORT_MMX}
  2217. { mmx support, this must be before the zero based array
  2218. check }
  2219. else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(ld) and
  2220. is_mmx_able_array(rd) then
  2221. begin
  2222. expectloc:=LOC_MMXREGISTER;
  2223. calcregisters(self,0,0,1);
  2224. end
  2225. {$endif SUPPORT_MMX}
  2226. else if (rd.deftype=pointerdef) or (ld.deftype=pointerdef) then
  2227. begin
  2228. expectloc:=LOC_REGISTER;
  2229. calcregisters(self,1,0,0);
  2230. end
  2231. else if (rd.deftype=procvardef) and
  2232. (ld.deftype=procvardef) and
  2233. equal_defs(rd,ld) then
  2234. begin
  2235. expectloc:=LOC_FLAGS;
  2236. calcregisters(self,1,0,0);
  2237. end
  2238. else if (ld.deftype=enumdef) then
  2239. begin
  2240. expectloc:=LOC_FLAGS;
  2241. calcregisters(self,1,0,0);
  2242. end
  2243. {$ifdef SUPPORT_MMX}
  2244. else if (cs_mmx in aktlocalswitches) and
  2245. is_mmx_able_array(ld) and
  2246. is_mmx_able_array(rd) then
  2247. begin
  2248. expectloc:=LOC_MMXREGISTER;
  2249. calcregisters(self,0,0,1);
  2250. end
  2251. {$endif SUPPORT_MMX}
  2252. { the general solution is to convert to 32 bit int }
  2253. else
  2254. begin
  2255. expectloc:=LOC_REGISTER;
  2256. calcregisters(self,1,0,0);
  2257. end;
  2258. end;
  2259. {$ifdef state_tracking}
  2260. function Taddnode.track_state_pass(exec_known:boolean):boolean;
  2261. var factval:Tnode;
  2262. begin
  2263. track_state_pass:=false;
  2264. if left.track_state_pass(exec_known) then
  2265. begin
  2266. track_state_pass:=true;
  2267. left.resulttype.def:=nil;
  2268. do_resulttypepass(left);
  2269. end;
  2270. factval:=aktstate.find_fact(left);
  2271. if factval<>nil then
  2272. begin
  2273. track_state_pass:=true;
  2274. left.destroy;
  2275. left:=factval.getcopy;
  2276. end;
  2277. if right.track_state_pass(exec_known) then
  2278. begin
  2279. track_state_pass:=true;
  2280. right.resulttype.def:=nil;
  2281. do_resulttypepass(right);
  2282. end;
  2283. factval:=aktstate.find_fact(right);
  2284. if factval<>nil then
  2285. begin
  2286. track_state_pass:=true;
  2287. right.destroy;
  2288. right:=factval.getcopy;
  2289. end;
  2290. end;
  2291. {$endif}
  2292. begin
  2293. caddnode:=taddnode;
  2294. end.