nadd.pas 91 KB

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