ncon.pas 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020
  1. {
  2. $Id$
  3. Copyright (c) 2000-2002 by Florian Klaempfl
  4. Type checking and register allocation for constants
  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 ncon;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. globtype,widestr,
  23. node,
  24. aasmbase,aasmtai,cpuinfo,globals,
  25. symconst,symppu,symtype,symdef,symsym;
  26. type
  27. trealconstnode = class(tnode)
  28. restype : ttype;
  29. value_real : bestreal;
  30. lab_real : tasmlabel;
  31. constructor create(v : bestreal;const t:ttype);virtual;
  32. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  33. procedure ppuwrite(ppufile:tcompilerppufile);override;
  34. procedure derefimpl;override;
  35. function getcopy : tnode;override;
  36. function pass_1 : tnode;override;
  37. function det_resulttype:tnode;override;
  38. function docompare(p: tnode) : boolean; override;
  39. end;
  40. trealconstnodeclass = class of trealconstnode;
  41. tordconstnode = class(tnode)
  42. restype : ttype;
  43. value : TConstExprInt;
  44. rangecheck : boolean;
  45. { create an ordinal constant node of the specified type and value.
  46. _rangecheck determines if the value of the ordinal should be checked
  47. against the ranges of the type definition.
  48. }
  49. constructor create(v : tconstexprint;const t:ttype; _rangecheck : boolean);virtual;
  50. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  51. procedure ppuwrite(ppufile:tcompilerppufile);override;
  52. procedure derefimpl;override;
  53. function getcopy : tnode;override;
  54. function pass_1 : tnode;override;
  55. function det_resulttype:tnode;override;
  56. function docompare(p: tnode) : boolean; override;
  57. {$ifdef extdebug}
  58. procedure _dowrite;override;
  59. {$endif}
  60. end;
  61. tordconstnodeclass = class of tordconstnode;
  62. tpointerconstnode = class(tnode)
  63. restype : ttype;
  64. value : TConstPtrUInt;
  65. constructor create(v : TConstPtrUInt;const t:ttype);virtual;
  66. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  67. procedure ppuwrite(ppufile:tcompilerppufile);override;
  68. procedure derefimpl;override;
  69. function getcopy : tnode;override;
  70. function pass_1 : tnode;override;
  71. function det_resulttype:tnode;override;
  72. function docompare(p: tnode) : boolean; override;
  73. end;
  74. tpointerconstnodeclass = class of tpointerconstnode;
  75. tstringconstnode = class(tnode)
  76. value_str : pchar;
  77. len : longint;
  78. lab_str : tasmlabel;
  79. st_type : tstringtype;
  80. constructor createstr(const s : string;st:tstringtype);virtual;
  81. constructor createpchar(s : pchar;l : longint);virtual;
  82. constructor createwstr(w : pcompilerwidestring);virtual;
  83. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  84. procedure ppuwrite(ppufile:tcompilerppufile);override;
  85. procedure derefimpl;override;
  86. destructor destroy;override;
  87. function getcopy : tnode;override;
  88. function pass_1 : tnode;override;
  89. function det_resulttype:tnode;override;
  90. function getpcharcopy : pchar;
  91. function docompare(p: tnode) : boolean; override;
  92. end;
  93. tstringconstnodeclass = class of tstringconstnode;
  94. tsetconstnode = class(tunarynode)
  95. restype : ttype;
  96. value_set : pconstset;
  97. lab_set : tasmlabel;
  98. constructor create(s : pconstset;const t:ttype);virtual;
  99. destructor destroy;override;
  100. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. procedure derefimpl;override;
  103. function getcopy : tnode;override;
  104. function pass_1 : tnode;override;
  105. function det_resulttype:tnode;override;
  106. function docompare(p: tnode) : boolean; override;
  107. end;
  108. tsetconstnodeclass = class of tsetconstnode;
  109. tnilnode = class(tnode)
  110. constructor create;virtual;
  111. function pass_1 : tnode;override;
  112. function det_resulttype:tnode;override;
  113. end;
  114. tnilnodeclass = class of tnilnode;
  115. tguidconstnode = class(tnode)
  116. value : tguid;
  117. constructor create(const g:tguid);virtual;
  118. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  119. procedure ppuwrite(ppufile:tcompilerppufile);override;
  120. function getcopy : tnode;override;
  121. function pass_1 : tnode;override;
  122. function det_resulttype:tnode;override;
  123. function docompare(p: tnode) : boolean; override;
  124. end;
  125. tguidconstnodeclass = class of tguidconstnode;
  126. var
  127. crealconstnode : trealconstnodeclass;
  128. cordconstnode : tordconstnodeclass;
  129. cpointerconstnode : tpointerconstnodeclass;
  130. cstringconstnode : tstringconstnodeclass;
  131. csetconstnode : tsetconstnodeclass;
  132. cguidconstnode : tguidconstnodeclass;
  133. cnilnode : tnilnodeclass;
  134. function genintconstnode(v : TConstExprInt) : tordconstnode;
  135. function genenumnode(v : tenumsym) : tordconstnode;
  136. { some helper routines }
  137. {$ifdef INT64FUNCRESOK}
  138. function get_ordinal_value(p : tnode) : TConstExprInt;
  139. {$else INT64FUNCRESOK}
  140. function get_ordinal_value(p : tnode) : longint;
  141. {$endif INT64FUNCRESOK}
  142. function is_constnode(p : tnode) : boolean;
  143. function is_constintnode(p : tnode) : boolean;
  144. function is_constcharnode(p : tnode) : boolean;
  145. function is_constrealnode(p : tnode) : boolean;
  146. function is_constboolnode(p : tnode) : boolean;
  147. function is_constresourcestringnode(p : tnode) : boolean;
  148. function is_constwidecharnode(p : tnode) : boolean;
  149. function str_length(p : tnode) : longint;
  150. function is_emptyset(p : tnode):boolean;
  151. function genconstsymtree(p : tconstsym) : tnode;
  152. implementation
  153. uses
  154. cutils,verbose,systems,
  155. defbase,cpubase,nld;
  156. function genintconstnode(v : TConstExprInt) : tordconstnode;
  157. var
  158. i,i2 : TConstExprInt;
  159. begin
  160. { we need to bootstrap this code, so it's a little bit messy }
  161. i:=2147483647;
  162. { maxcardinal }
  163. i2 := i+i+1;
  164. if (v<=i) and (v>=-i-1) then
  165. genintconstnode:=cordconstnode.create(v,s32bittype,true)
  166. else if (v > i) and (v <= i2) then
  167. genintconstnode:=cordconstnode.create(v,u32bittype,true)
  168. else
  169. genintconstnode:=cordconstnode.create(v,cs64bittype,true);
  170. end;
  171. function genenumnode(v : tenumsym) : tordconstnode;
  172. var
  173. htype : ttype;
  174. begin
  175. htype.setdef(v.definition);
  176. genenumnode:=cordconstnode.create(v.value,htype,true);
  177. end;
  178. {$ifdef INT64FUNCRESOK}
  179. function get_ordinal_value(p : tnode) : TConstExprInt;
  180. {$else INT64FUNCRESOK}
  181. function get_ordinal_value(p : tnode) : longint;
  182. {$endif INT64FUNCRESOK}
  183. begin
  184. if p.nodetype=ordconstn then
  185. get_ordinal_value:=tordconstnode(p).value
  186. else
  187. begin
  188. Message(type_e_ordinal_expr_expected);
  189. get_ordinal_value:=0;
  190. end;
  191. end;
  192. function is_constnode(p : tnode) : boolean;
  193. begin
  194. is_constnode:=(p.nodetype in [ordconstn,realconstn,stringconstn,setconstn,guidconstn]);
  195. end;
  196. function is_constintnode(p : tnode) : boolean;
  197. begin
  198. is_constintnode:=(p.nodetype=ordconstn) and is_integer(p.resulttype.def);
  199. end;
  200. function is_constcharnode(p : tnode) : boolean;
  201. begin
  202. is_constcharnode:=(p.nodetype=ordconstn) and is_char(p.resulttype.def);
  203. end;
  204. function is_constwidecharnode(p : tnode) : boolean;
  205. begin
  206. is_constwidecharnode:=(p.nodetype=ordconstn) and is_widechar(p.resulttype.def);
  207. end;
  208. function is_constrealnode(p : tnode) : boolean;
  209. begin
  210. is_constrealnode:=(p.nodetype=realconstn);
  211. end;
  212. function is_constboolnode(p : tnode) : boolean;
  213. begin
  214. is_constboolnode:=(p.nodetype=ordconstn) and is_boolean(p.resulttype.def);
  215. end;
  216. function is_constresourcestringnode(p : tnode) : boolean;
  217. begin
  218. is_constresourcestringnode:=(p.nodetype=loadn) and
  219. (tloadnode(p).symtableentry.typ=constsym) and
  220. (tconstsym(tloadnode(p).symtableentry).consttyp=constresourcestring);
  221. end;
  222. function str_length(p : tnode) : longint;
  223. begin
  224. str_length:=tstringconstnode(p).len;
  225. end;
  226. {$ifdef oldset}
  227. function is_emptyset(p : tnode):boolean;
  228. var
  229. i : longint;
  230. begin
  231. i:=0;
  232. if p.nodetype=setconstn then
  233. begin
  234. while (i<32) and (tsetconstnode(p).value_set^[i]=0) do
  235. inc(i);
  236. end;
  237. is_emptyset:=(i=32);
  238. end;
  239. {$else}
  240. function is_emptyset(p : tnode):boolean;
  241. begin
  242. is_emptyset:=(p.nodetype=setconstn) and
  243. (Tsetconstnode(p).value_set^=[]);
  244. end;
  245. {$endif}
  246. function genconstsymtree(p : tconstsym) : tnode;
  247. var
  248. p1 : tnode;
  249. len : longint;
  250. pc : pchar;
  251. begin
  252. p1:=nil;
  253. case p.consttyp of
  254. constint :
  255. p1:=genintconstnode(p.valueord);
  256. conststring :
  257. begin
  258. len:=p.len;
  259. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  260. len:=255;
  261. getmem(pc,len+1);
  262. move(pchar(p.valueptr)^,pc^,len);
  263. pc[len]:=#0;
  264. p1:=cstringconstnode.createpchar(pc,len);
  265. end;
  266. constchar :
  267. p1:=cordconstnode.create(p.valueord,cchartype,true);
  268. constreal :
  269. p1:=crealconstnode.create(pbestreal(p.valueptr)^,pbestrealtype^);
  270. constbool :
  271. p1:=cordconstnode.create(p.valueord,booltype,true);
  272. constset :
  273. p1:=csetconstnode.create(pconstset(p.valueptr),p.consttype);
  274. constord :
  275. p1:=cordconstnode.create(p.valueord,p.consttype,true);
  276. constpointer :
  277. p1:=cpointerconstnode.create(p.valueordptr,p.consttype);
  278. constnil :
  279. p1:=cnilnode.create;
  280. else
  281. internalerror(200205103);
  282. end;
  283. genconstsymtree:=p1;
  284. end;
  285. {*****************************************************************************
  286. TREALCONSTNODE
  287. *****************************************************************************}
  288. { generic code }
  289. { overridden by: }
  290. { i386 }
  291. constructor trealconstnode.create(v : bestreal;const t:ttype);
  292. begin
  293. inherited create(realconstn);
  294. restype:=t;
  295. value_real:=v;
  296. lab_real:=nil;
  297. end;
  298. constructor trealconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  299. begin
  300. inherited ppuload(t,ppufile);
  301. ppufile.gettype(restype);
  302. value_real:=ppufile.getreal;
  303. lab_real:=tasmlabel(ppufile.getasmsymbol);
  304. end;
  305. procedure trealconstnode.ppuwrite(ppufile:tcompilerppufile);
  306. begin
  307. inherited ppuwrite(ppufile);
  308. ppufile.puttype(restype);
  309. ppufile.putreal(value_real);
  310. ppufile.putasmsymbol(lab_real);
  311. end;
  312. procedure trealconstnode.derefimpl;
  313. begin
  314. inherited derefimpl;
  315. restype.resolve;
  316. objectlibrary.derefasmsymbol(tasmsymbol(lab_real));
  317. end;
  318. function trealconstnode.getcopy : tnode;
  319. var
  320. n : trealconstnode;
  321. begin
  322. n:=trealconstnode(inherited getcopy);
  323. n.value_real:=value_real;
  324. n.lab_real:=lab_real;
  325. getcopy:=n;
  326. end;
  327. function trealconstnode.det_resulttype:tnode;
  328. begin
  329. result:=nil;
  330. resulttype:=restype;
  331. end;
  332. function trealconstnode.pass_1 : tnode;
  333. begin
  334. result:=nil;
  335. location.loc:=LOC_CREFERENCE;
  336. { needs to be loaded into an FPU register }
  337. registersfpu:=1;
  338. end;
  339. function trealconstnode.docompare(p: tnode): boolean;
  340. begin
  341. docompare :=
  342. inherited docompare(p) and
  343. (value_real = trealconstnode(p).value_real);
  344. end;
  345. {*****************************************************************************
  346. TORDCONSTNODE
  347. *****************************************************************************}
  348. constructor tordconstnode.create(v : tconstexprint;const t:ttype;_rangecheck : boolean);
  349. begin
  350. inherited create(ordconstn);
  351. value:=v;
  352. restype:=t;
  353. rangecheck := _rangecheck;
  354. end;
  355. constructor tordconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  356. begin
  357. inherited ppuload(t,ppufile);
  358. ppufile.gettype(restype);
  359. value:=ppufile.getexprint;
  360. { normally, the value is already compiled, so we don't need
  361. to do once again a range check
  362. }
  363. rangecheck := false;
  364. end;
  365. procedure tordconstnode.ppuwrite(ppufile:tcompilerppufile);
  366. begin
  367. inherited ppuwrite(ppufile);
  368. ppufile.puttype(restype);
  369. ppufile.putexprint(value);
  370. end;
  371. procedure tordconstnode.derefimpl;
  372. begin
  373. inherited derefimpl;
  374. restype.resolve;
  375. end;
  376. function tordconstnode.getcopy : tnode;
  377. var
  378. n : tordconstnode;
  379. begin
  380. n:=tordconstnode(inherited getcopy);
  381. n.value:=value;
  382. n.restype := restype;
  383. getcopy:=n;
  384. end;
  385. function tordconstnode.det_resulttype:tnode;
  386. begin
  387. result:=nil;
  388. resulttype:=restype;
  389. { only do range checking when explicitly asked for it }
  390. if rangecheck then
  391. testrange(resulttype.def,value,false);
  392. end;
  393. function tordconstnode.pass_1 : tnode;
  394. begin
  395. result:=nil;
  396. if is_64bitint(resulttype.def) then
  397. location.loc:=LOC_CREFERENCE
  398. else
  399. location.loc:=LOC_CONSTANT;
  400. end;
  401. function tordconstnode.docompare(p: tnode): boolean;
  402. begin
  403. docompare :=
  404. inherited docompare(p) and
  405. (value = tordconstnode(p).value);
  406. end;
  407. {$ifdef extdebug}
  408. procedure Tordconstnode._dowrite;
  409. begin
  410. inherited _dowrite;
  411. system.write(',value = ',value);
  412. end;
  413. {$endif}
  414. {*****************************************************************************
  415. TPOINTERCONSTNODE
  416. *****************************************************************************}
  417. constructor tpointerconstnode.create(v : TConstPtrUInt;const t:ttype);
  418. begin
  419. inherited create(pointerconstn);
  420. value:=v;
  421. restype:=t;
  422. end;
  423. constructor tpointerconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  424. begin
  425. inherited ppuload(t,ppufile);
  426. ppufile.gettype(restype);
  427. value:=ppufile.getptruint;
  428. end;
  429. procedure tpointerconstnode.ppuwrite(ppufile:tcompilerppufile);
  430. begin
  431. inherited ppuwrite(ppufile);
  432. ppufile.puttype(restype);
  433. ppufile.putptruint(value);
  434. end;
  435. procedure tpointerconstnode.derefimpl;
  436. begin
  437. inherited derefimpl;
  438. restype.resolve;
  439. end;
  440. function tpointerconstnode.getcopy : tnode;
  441. var
  442. n : tpointerconstnode;
  443. begin
  444. n:=tpointerconstnode(inherited getcopy);
  445. n.value:=value;
  446. n.restype := restype;
  447. getcopy:=n;
  448. end;
  449. function tpointerconstnode.det_resulttype:tnode;
  450. begin
  451. result:=nil;
  452. resulttype:=restype;
  453. end;
  454. function tpointerconstnode.pass_1 : tnode;
  455. begin
  456. result:=nil;
  457. location.loc:=LOC_CONSTANT;
  458. end;
  459. function tpointerconstnode.docompare(p: tnode): boolean;
  460. begin
  461. docompare :=
  462. inherited docompare(p) and
  463. (value = tpointerconstnode(p).value);
  464. end;
  465. {*****************************************************************************
  466. TSTRINGCONSTNODE
  467. *****************************************************************************}
  468. constructor tstringconstnode.createstr(const s : string;st:tstringtype);
  469. var
  470. l : longint;
  471. begin
  472. inherited create(stringconstn);
  473. l:=length(s);
  474. len:=l;
  475. { stringdup write even past a #0 }
  476. getmem(value_str,l+1);
  477. move(s[1],value_str^,l);
  478. value_str[l]:=#0;
  479. lab_str:=nil;
  480. if st=st_default then
  481. begin
  482. if cs_ansistrings in aktlocalswitches then
  483. st_type:=st_ansistring
  484. else
  485. st_type:=st_shortstring;
  486. end
  487. else
  488. st_type:=st;
  489. end;
  490. constructor tstringconstnode.createwstr(w : pcompilerwidestring);
  491. begin
  492. inherited create(stringconstn);
  493. len:=getlengthwidestring(w);
  494. initwidestring(pcompilerwidestring(value_str));
  495. copywidestring(w,pcompilerwidestring(value_str));
  496. lab_str:=nil;
  497. st_type:=st_widestring;
  498. end;
  499. constructor tstringconstnode.createpchar(s : pchar;l : longint);
  500. begin
  501. inherited create(stringconstn);
  502. len:=l;
  503. value_str:=s;
  504. if (cs_ansistrings in aktlocalswitches) or
  505. (len>255) then
  506. st_type:=st_ansistring
  507. else
  508. st_type:=st_shortstring;
  509. lab_str:=nil;
  510. end;
  511. destructor tstringconstnode.destroy;
  512. begin
  513. if st_type=st_widestring then
  514. donewidestring(pcompilerwidestring(value_str))
  515. else
  516. ansistringdispose(value_str,len);
  517. inherited destroy;
  518. end;
  519. constructor tstringconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  520. begin
  521. inherited ppuload(t,ppufile);
  522. st_type:=tstringtype(ppufile.getbyte);
  523. len:=ppufile.getlongint;
  524. getmem(value_str,len+1);
  525. ppufile.getdata(value_str^,len);
  526. value_str[len]:=#0;
  527. lab_str:=tasmlabel(ppufile.getasmsymbol);
  528. end;
  529. procedure tstringconstnode.ppuwrite(ppufile:tcompilerppufile);
  530. begin
  531. inherited ppuwrite(ppufile);
  532. ppufile.putbyte(byte(st_type));
  533. ppufile.putlongint(len);
  534. ppufile.putdata(value_str^,len);
  535. ppufile.putasmsymbol(lab_str);
  536. end;
  537. procedure tstringconstnode.derefimpl;
  538. begin
  539. inherited derefimpl;
  540. objectlibrary.derefasmsymbol(tasmsymbol(lab_str));
  541. end;
  542. function tstringconstnode.getcopy : tnode;
  543. var
  544. n : tstringconstnode;
  545. begin
  546. n:=tstringconstnode(inherited getcopy);
  547. n.st_type:=st_type;
  548. n.len:=len;
  549. n.lab_str:=lab_str;
  550. if st_type=st_widestring then
  551. begin
  552. initwidestring(pcompilerwidestring(n.value_str));
  553. copywidestring(pcompilerwidestring(value_str),pcompilerwidestring(n.value_str));
  554. end
  555. else
  556. n.value_str:=getpcharcopy;
  557. getcopy:=n;
  558. end;
  559. function tstringconstnode.det_resulttype:tnode;
  560. begin
  561. result:=nil;
  562. case st_type of
  563. st_shortstring :
  564. resulttype:=cshortstringtype;
  565. st_ansistring :
  566. resulttype:=cansistringtype;
  567. st_widestring :
  568. resulttype:=cwidestringtype;
  569. st_longstring :
  570. resulttype:=clongstringtype;
  571. end;
  572. end;
  573. function tstringconstnode.pass_1 : tnode;
  574. begin
  575. result:=nil;
  576. location.loc:=LOC_CREFERENCE;
  577. end;
  578. function tstringconstnode.getpcharcopy : pchar;
  579. var
  580. pc : pchar;
  581. begin
  582. pc:=nil;
  583. getmem(pc,len+1);
  584. if pc=nil then
  585. Message(general_f_no_memory_left);
  586. move(value_str^,pc^,len+1);
  587. getpcharcopy:=pc;
  588. end;
  589. function tstringconstnode.docompare(p: tnode): boolean;
  590. begin
  591. docompare :=
  592. inherited docompare(p) and
  593. (len = tstringconstnode(p).len) and
  594. { Don't compare the pchars, since they may contain null chars }
  595. { Since all equal constant strings are replaced by the same }
  596. { label, the following compare should be enough (JM) }
  597. (lab_str = tstringconstnode(p).lab_str);
  598. end;
  599. {*****************************************************************************
  600. TSETCONSTNODE
  601. *****************************************************************************}
  602. constructor tsetconstnode.create(s : pconstset;const t:ttype);
  603. begin
  604. inherited create(setconstn,nil);
  605. restype:=t;
  606. if assigned(s) then
  607. begin
  608. new(value_set);
  609. value_set^:=s^;
  610. end
  611. else
  612. value_set:=nil;
  613. end;
  614. destructor tsetconstnode.destroy;
  615. begin
  616. if assigned(value_set) then
  617. dispose(value_set);
  618. inherited destroy;
  619. end;
  620. constructor tsetconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  621. begin
  622. inherited ppuload(t,ppufile);
  623. ppufile.gettype(restype);
  624. new(value_set);
  625. ppufile.getdata(value_set^,sizeof(tconstset));
  626. end;
  627. procedure tsetconstnode.ppuwrite(ppufile:tcompilerppufile);
  628. begin
  629. inherited ppuwrite(ppufile);
  630. ppufile.puttype(restype);
  631. ppufile.putdata(value_set^,sizeof(tconstset));
  632. end;
  633. procedure tsetconstnode.derefimpl;
  634. begin
  635. inherited derefimpl;
  636. restype.resolve;
  637. end;
  638. function tsetconstnode.getcopy : tnode;
  639. var
  640. n : tsetconstnode;
  641. begin
  642. n:=tsetconstnode(inherited getcopy);
  643. if assigned(value_set) then
  644. begin
  645. new(n.value_set);
  646. n.value_set^:=value_set^
  647. end
  648. else
  649. n.value_set:=nil;
  650. n.restype := restype;
  651. n.lab_set:=lab_set;
  652. getcopy:=n;
  653. end;
  654. function tsetconstnode.det_resulttype:tnode;
  655. begin
  656. result:=nil;
  657. resulttype:=restype;
  658. end;
  659. function tsetconstnode.pass_1 : tnode;
  660. begin
  661. result:=nil;
  662. if tsetdef(resulttype.def).settype=smallset then
  663. location.loc:=LOC_CONSTANT
  664. else
  665. location.loc:=LOC_CREFERENCE;
  666. end;
  667. {$ifdef oldset}
  668. function tsetconstnode.docompare(p: tnode): boolean;
  669. var
  670. i: 0..31;
  671. begin
  672. if inherited docompare(p) then
  673. begin
  674. for i := 0 to 31 do
  675. if (value_set^[i] <> tsetconstnode(p).value_set^[i]) then
  676. begin
  677. docompare := false;
  678. exit
  679. end;
  680. docompare := true;
  681. end
  682. else
  683. docompare := false;
  684. end;
  685. {$else}
  686. function tsetconstnode.docompare(p: tnode): boolean;
  687. begin
  688. docompare:=(inherited docompare(p))
  689. and (value_set^=Tsetconstnode(p).value_set^);
  690. end;
  691. {$endif}
  692. {*****************************************************************************
  693. TNILNODE
  694. *****************************************************************************}
  695. constructor tnilnode.create;
  696. begin
  697. inherited create(niln);
  698. end;
  699. function tnilnode.det_resulttype:tnode;
  700. begin
  701. result:=nil;
  702. resulttype:=voidpointertype;
  703. end;
  704. function tnilnode.pass_1 : tnode;
  705. begin
  706. result:=nil;
  707. location.loc:=LOC_CONSTANT;
  708. end;
  709. {*****************************************************************************
  710. TGUIDCONSTNODE
  711. *****************************************************************************}
  712. constructor tguidconstnode.create(const g:tguid);
  713. begin
  714. inherited create(guidconstn);
  715. value:=g;
  716. end;
  717. constructor tguidconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  718. begin
  719. inherited ppuload(t,ppufile);
  720. ppufile.getguid(value);
  721. end;
  722. procedure tguidconstnode.ppuwrite(ppufile:tcompilerppufile);
  723. begin
  724. inherited ppuwrite(ppufile);
  725. ppufile.putguid(value);
  726. end;
  727. function tguidconstnode.getcopy : tnode;
  728. var
  729. n : tguidconstnode;
  730. begin
  731. n:=tguidconstnode(inherited getcopy);
  732. n.value:=value;
  733. getcopy:=n;
  734. end;
  735. function tguidconstnode.det_resulttype:tnode;
  736. begin
  737. result:=nil;
  738. resulttype.setdef(rec_tguid);
  739. end;
  740. function tguidconstnode.pass_1 : tnode;
  741. begin
  742. result:=nil;
  743. location.loc:=LOC_CREFERENCE;
  744. end;
  745. function tguidconstnode.docompare(p: tnode): boolean;
  746. begin
  747. docompare :=
  748. inherited docompare(p) and
  749. (guid2string(value) = guid2string(tguidconstnode(p).value));
  750. end;
  751. begin
  752. crealconstnode:=trealconstnode;
  753. cordconstnode:=tordconstnode;
  754. cpointerconstnode:=tpointerconstnode;
  755. cstringconstnode:=tstringconstnode;
  756. csetconstnode:=tsetconstnode;
  757. cnilnode:=tnilnode;
  758. cguidconstnode:=tguidconstnode;
  759. end.
  760. {
  761. $Log$
  762. Revision 1.43 2002-10-05 12:43:25 carl
  763. * fixes for Delphi 6 compilation
  764. (warning : Some features do not work under Delphi)
  765. Revision 1.42 2002/09/07 15:25:03 peter
  766. * old logs removed and tabs fixed
  767. Revision 1.41 2002/09/07 12:16:04 carl
  768. * second part bug report 1996 fix, testrange in cordconstnode
  769. only called if option is set (also make parsing a tiny faster)
  770. Revision 1.40 2002/08/22 11:21:44 florian
  771. + register32 is now written by tnode.dowrite
  772. * fixed write of value of tconstnode
  773. Revision 1.39 2002/08/18 20:06:23 peter
  774. * inlining is now also allowed in interface
  775. * renamed write/load to ppuwrite/ppuload
  776. * tnode storing in ppu
  777. * nld,ncon,nbas are already updated for storing in ppu
  778. Revision 1.38 2002/08/17 22:09:45 florian
  779. * result type handling in tcgcal.pass_2 overhauled
  780. * better tnode.dowrite
  781. * some ppc stuff fixed
  782. Revision 1.37 2002/07/23 12:34:30 daniel
  783. * Readded old set code. To use it define 'oldset'. Activated by default
  784. for ppc.
  785. Revision 1.36 2002/07/22 11:48:04 daniel
  786. * Sets are now internally sets.
  787. Revision 1.35 2002/07/20 11:57:54 florian
  788. * types.pas renamed to defbase.pas because D6 contains a types
  789. unit so this would conflicts if D6 programms are compiled
  790. + Willamette/SSE2 instructions to assembler added
  791. Revision 1.34 2002/07/14 18:00:43 daniel
  792. + Added the beginning of a state tracker. This will track the values of
  793. variables through procedures and optimize things away.
  794. Revision 1.33 2002/07/01 18:46:23 peter
  795. * internal linker
  796. * reorganized aasm layer
  797. Revision 1.32 2002/05/18 13:34:09 peter
  798. * readded missing revisions
  799. Revision 1.31 2002/05/16 19:46:37 carl
  800. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  801. + try to fix temp allocation (still in ifdef)
  802. + generic constructor calls
  803. + start of tassembler / tmodulebase class cleanup
  804. Revision 1.29 2002/05/12 16:53:07 peter
  805. * moved entry and exitcode to ncgutil and cgobj
  806. * foreach gets extra argument for passing local data to the
  807. iterator function
  808. * -CR checks also class typecasts at runtime by changing them
  809. into as
  810. * fixed compiler to cycle with the -CR option
  811. * fixed stabs with elf writer, finally the global variables can
  812. be watched
  813. * removed a lot of routines from cga unit and replaced them by
  814. calls to cgobj
  815. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  816. u32bit then the other is typecasted also to u32bit without giving
  817. a rangecheck warning/error.
  818. * fixed pascal calling method with reversing also the high tree in
  819. the parast, detected by tcalcst3 test
  820. Revision 1.28 2002/04/07 13:25:20 carl
  821. + change unit use
  822. Revision 1.27 2002/04/04 19:05:58 peter
  823. * removed unused units
  824. * use tlocation.size in cg.a_*loc*() routines
  825. Revision 1.26 2002/04/02 17:11:29 peter
  826. * tlocation,treference update
  827. * LOC_CONSTANT added for better constant handling
  828. * secondadd splitted in multiple routines
  829. * location_force_reg added for loading a location to a register
  830. of a specified size
  831. * secondassignment parses now first the right and then the left node
  832. (this is compatible with Kylix). This saves a lot of push/pop especially
  833. with string operations
  834. * adapted some routines to use the new cg methods
  835. Revision 1.25 2002/03/04 19:10:11 peter
  836. * removed compiler warnings
  837. }