ncon.pas 30 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034
  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. defutil,cpubase,cginfo,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.value.valueord);
  256. conststring :
  257. begin
  258. len:=p.value.len;
  259. if not(cs_ansistrings in aktlocalswitches) and (len>255) then
  260. len:=255;
  261. getmem(pc,len+1);
  262. move(pchar(p.value.valueptr)^,pc^,len);
  263. pc[len]:=#0;
  264. p1:=cstringconstnode.createpchar(pc,len);
  265. end;
  266. constchar :
  267. p1:=cordconstnode.create(p.value.valueord,cchartype,true);
  268. constreal :
  269. p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,pbestrealtype^);
  270. constbool :
  271. p1:=cordconstnode.create(p.value.valueord,booltype,true);
  272. constset :
  273. p1:=csetconstnode.create(pconstset(p.value.valueptr),p.consttype);
  274. constord :
  275. p1:=cordconstnode.create(p.value.valueord,p.consttype,true);
  276. constpointer :
  277. p1:=cpointerconstnode.create(p.value.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. expectloc:=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. expectloc:=LOC_CONSTANT;
  397. end;
  398. function tordconstnode.docompare(p: tnode): boolean;
  399. begin
  400. docompare :=
  401. inherited docompare(p) and
  402. (value = tordconstnode(p).value);
  403. end;
  404. {$ifdef extdebug}
  405. procedure Tordconstnode._dowrite;
  406. begin
  407. inherited _dowrite;
  408. system.write(',value = ',value);
  409. end;
  410. {$endif}
  411. {*****************************************************************************
  412. TPOINTERCONSTNODE
  413. *****************************************************************************}
  414. constructor tpointerconstnode.create(v : TConstPtrUInt;const t:ttype);
  415. begin
  416. inherited create(pointerconstn);
  417. value:=v;
  418. restype:=t;
  419. end;
  420. constructor tpointerconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  421. begin
  422. inherited ppuload(t,ppufile);
  423. ppufile.gettype(restype);
  424. value:=ppufile.getptruint;
  425. end;
  426. procedure tpointerconstnode.ppuwrite(ppufile:tcompilerppufile);
  427. begin
  428. inherited ppuwrite(ppufile);
  429. ppufile.puttype(restype);
  430. ppufile.putptruint(value);
  431. end;
  432. procedure tpointerconstnode.derefimpl;
  433. begin
  434. inherited derefimpl;
  435. restype.resolve;
  436. end;
  437. function tpointerconstnode.getcopy : tnode;
  438. var
  439. n : tpointerconstnode;
  440. begin
  441. n:=tpointerconstnode(inherited getcopy);
  442. n.value:=value;
  443. n.restype := restype;
  444. getcopy:=n;
  445. end;
  446. function tpointerconstnode.det_resulttype:tnode;
  447. begin
  448. result:=nil;
  449. resulttype:=restype;
  450. end;
  451. function tpointerconstnode.pass_1 : tnode;
  452. begin
  453. result:=nil;
  454. expectloc:=LOC_CONSTANT;
  455. end;
  456. function tpointerconstnode.docompare(p: tnode): boolean;
  457. begin
  458. docompare :=
  459. inherited docompare(p) and
  460. (value = tpointerconstnode(p).value);
  461. end;
  462. {*****************************************************************************
  463. TSTRINGCONSTNODE
  464. *****************************************************************************}
  465. constructor tstringconstnode.createstr(const s : string;st:tstringtype);
  466. var
  467. l : longint;
  468. begin
  469. inherited create(stringconstn);
  470. l:=length(s);
  471. len:=l;
  472. { stringdup write even past a #0 }
  473. getmem(value_str,l+1);
  474. move(s[1],value_str^,l);
  475. value_str[l]:=#0;
  476. lab_str:=nil;
  477. if st=st_default then
  478. begin
  479. if cs_ansistrings in aktlocalswitches then
  480. st_type:=st_ansistring
  481. else
  482. st_type:=st_shortstring;
  483. end
  484. else
  485. st_type:=st;
  486. end;
  487. constructor tstringconstnode.createwstr(w : pcompilerwidestring);
  488. begin
  489. inherited create(stringconstn);
  490. len:=getlengthwidestring(w);
  491. initwidestring(pcompilerwidestring(value_str));
  492. copywidestring(w,pcompilerwidestring(value_str));
  493. lab_str:=nil;
  494. st_type:=st_widestring;
  495. end;
  496. constructor tstringconstnode.createpchar(s : pchar;l : longint);
  497. begin
  498. inherited create(stringconstn);
  499. len:=l;
  500. value_str:=s;
  501. if (cs_ansistrings in aktlocalswitches) or
  502. (len>255) then
  503. st_type:=st_ansistring
  504. else
  505. st_type:=st_shortstring;
  506. lab_str:=nil;
  507. end;
  508. destructor tstringconstnode.destroy;
  509. begin
  510. if st_type=st_widestring then
  511. donewidestring(pcompilerwidestring(value_str))
  512. else
  513. ansistringdispose(value_str,len);
  514. inherited destroy;
  515. end;
  516. constructor tstringconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  517. begin
  518. inherited ppuload(t,ppufile);
  519. st_type:=tstringtype(ppufile.getbyte);
  520. len:=ppufile.getlongint;
  521. getmem(value_str,len+1);
  522. ppufile.getdata(value_str^,len);
  523. value_str[len]:=#0;
  524. lab_str:=tasmlabel(ppufile.getasmsymbol);
  525. end;
  526. procedure tstringconstnode.ppuwrite(ppufile:tcompilerppufile);
  527. begin
  528. inherited ppuwrite(ppufile);
  529. ppufile.putbyte(byte(st_type));
  530. ppufile.putlongint(len);
  531. ppufile.putdata(value_str^,len);
  532. ppufile.putasmsymbol(lab_str);
  533. end;
  534. procedure tstringconstnode.derefimpl;
  535. begin
  536. inherited derefimpl;
  537. objectlibrary.derefasmsymbol(tasmsymbol(lab_str));
  538. end;
  539. function tstringconstnode.getcopy : tnode;
  540. var
  541. n : tstringconstnode;
  542. begin
  543. n:=tstringconstnode(inherited getcopy);
  544. n.st_type:=st_type;
  545. n.len:=len;
  546. n.lab_str:=lab_str;
  547. if st_type=st_widestring then
  548. begin
  549. initwidestring(pcompilerwidestring(n.value_str));
  550. copywidestring(pcompilerwidestring(value_str),pcompilerwidestring(n.value_str));
  551. end
  552. else
  553. n.value_str:=getpcharcopy;
  554. getcopy:=n;
  555. end;
  556. function tstringconstnode.det_resulttype:tnode;
  557. begin
  558. result:=nil;
  559. case st_type of
  560. st_shortstring :
  561. resulttype:=cshortstringtype;
  562. st_ansistring :
  563. resulttype:=cansistringtype;
  564. st_widestring :
  565. resulttype:=cwidestringtype;
  566. st_longstring :
  567. resulttype:=clongstringtype;
  568. end;
  569. end;
  570. function tstringconstnode.pass_1 : tnode;
  571. begin
  572. result:=nil;
  573. if (st_type in [st_ansistring,st_widestring]) and
  574. (len=0) then
  575. expectloc:=LOC_CONSTANT
  576. else
  577. expectloc:=LOC_CREFERENCE;
  578. end;
  579. function tstringconstnode.getpcharcopy : pchar;
  580. var
  581. pc : pchar;
  582. begin
  583. pc:=nil;
  584. getmem(pc,len+1);
  585. if pc=nil then
  586. Message(general_f_no_memory_left);
  587. move(value_str^,pc^,len+1);
  588. getpcharcopy:=pc;
  589. end;
  590. function tstringconstnode.docompare(p: tnode): boolean;
  591. begin
  592. docompare :=
  593. inherited docompare(p) and
  594. (len = tstringconstnode(p).len) and
  595. { Don't compare the pchars, since they may contain null chars }
  596. { Since all equal constant strings are replaced by the same }
  597. { label, the following compare should be enough (JM) }
  598. (lab_str = tstringconstnode(p).lab_str);
  599. end;
  600. {*****************************************************************************
  601. TSETCONSTNODE
  602. *****************************************************************************}
  603. constructor tsetconstnode.create(s : pconstset;const t:ttype);
  604. begin
  605. inherited create(setconstn,nil);
  606. restype:=t;
  607. if assigned(s) then
  608. begin
  609. new(value_set);
  610. value_set^:=s^;
  611. end
  612. else
  613. value_set:=nil;
  614. end;
  615. destructor tsetconstnode.destroy;
  616. begin
  617. if assigned(value_set) then
  618. dispose(value_set);
  619. inherited destroy;
  620. end;
  621. constructor tsetconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  622. begin
  623. inherited ppuload(t,ppufile);
  624. ppufile.gettype(restype);
  625. new(value_set);
  626. ppufile.getdata(value_set^,sizeof(tconstset));
  627. end;
  628. procedure tsetconstnode.ppuwrite(ppufile:tcompilerppufile);
  629. begin
  630. inherited ppuwrite(ppufile);
  631. ppufile.puttype(restype);
  632. ppufile.putdata(value_set^,sizeof(tconstset));
  633. end;
  634. procedure tsetconstnode.derefimpl;
  635. begin
  636. inherited derefimpl;
  637. restype.resolve;
  638. end;
  639. function tsetconstnode.getcopy : tnode;
  640. var
  641. n : tsetconstnode;
  642. begin
  643. n:=tsetconstnode(inherited getcopy);
  644. if assigned(value_set) then
  645. begin
  646. new(n.value_set);
  647. n.value_set^:=value_set^
  648. end
  649. else
  650. n.value_set:=nil;
  651. n.restype := restype;
  652. n.lab_set:=lab_set;
  653. getcopy:=n;
  654. end;
  655. function tsetconstnode.det_resulttype:tnode;
  656. begin
  657. result:=nil;
  658. resulttype:=restype;
  659. end;
  660. function tsetconstnode.pass_1 : tnode;
  661. begin
  662. result:=nil;
  663. if tsetdef(resulttype.def).settype=smallset then
  664. expectloc:=LOC_CONSTANT
  665. else
  666. expectloc:=LOC_CREFERENCE;
  667. end;
  668. {$ifdef oldset}
  669. function tsetconstnode.docompare(p: tnode): boolean;
  670. var
  671. i: 0..31;
  672. begin
  673. if inherited docompare(p) then
  674. begin
  675. for i := 0 to 31 do
  676. if (value_set^[i] <> tsetconstnode(p).value_set^[i]) then
  677. begin
  678. docompare := false;
  679. exit
  680. end;
  681. docompare := true;
  682. end
  683. else
  684. docompare := false;
  685. end;
  686. {$else}
  687. function tsetconstnode.docompare(p: tnode): boolean;
  688. begin
  689. docompare:=(inherited docompare(p))
  690. and (value_set^=Tsetconstnode(p).value_set^);
  691. end;
  692. {$endif}
  693. {*****************************************************************************
  694. TNILNODE
  695. *****************************************************************************}
  696. constructor tnilnode.create;
  697. begin
  698. inherited create(niln);
  699. end;
  700. function tnilnode.det_resulttype:tnode;
  701. begin
  702. result:=nil;
  703. resulttype:=voidpointertype;
  704. end;
  705. function tnilnode.pass_1 : tnode;
  706. begin
  707. result:=nil;
  708. expectloc:=LOC_CONSTANT;
  709. end;
  710. {*****************************************************************************
  711. TGUIDCONSTNODE
  712. *****************************************************************************}
  713. constructor tguidconstnode.create(const g:tguid);
  714. begin
  715. inherited create(guidconstn);
  716. value:=g;
  717. end;
  718. constructor tguidconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  719. begin
  720. inherited ppuload(t,ppufile);
  721. ppufile.getguid(value);
  722. end;
  723. procedure tguidconstnode.ppuwrite(ppufile:tcompilerppufile);
  724. begin
  725. inherited ppuwrite(ppufile);
  726. ppufile.putguid(value);
  727. end;
  728. function tguidconstnode.getcopy : tnode;
  729. var
  730. n : tguidconstnode;
  731. begin
  732. n:=tguidconstnode(inherited getcopy);
  733. n.value:=value;
  734. getcopy:=n;
  735. end;
  736. function tguidconstnode.det_resulttype:tnode;
  737. begin
  738. result:=nil;
  739. resulttype.setdef(rec_tguid);
  740. end;
  741. function tguidconstnode.pass_1 : tnode;
  742. begin
  743. result:=nil;
  744. expectloc:=LOC_CREFERENCE;
  745. end;
  746. function tguidconstnode.docompare(p: tnode): boolean;
  747. begin
  748. docompare :=
  749. inherited docompare(p) and
  750. (guid2string(value) = guid2string(tguidconstnode(p).value));
  751. end;
  752. begin
  753. crealconstnode:=trealconstnode;
  754. cordconstnode:=tordconstnode;
  755. cpointerconstnode:=tpointerconstnode;
  756. cstringconstnode:=tstringconstnode;
  757. csetconstnode:=tsetconstnode;
  758. cnilnode:=tnilnode;
  759. cguidconstnode:=tguidconstnode;
  760. end.
  761. {
  762. $Log$
  763. Revision 1.46 2003-04-22 23:50:23 peter
  764. * firstpass uses expectloc
  765. * checks if there are differences between the expectloc and
  766. location.loc from secondpass in EXTDEBUG
  767. Revision 1.45 2002/11/25 17:43:18 peter
  768. * splitted defbase in defutil,symutil,defcmp
  769. * merged isconvertable and is_equal into compare_defs(_ext)
  770. * made operator search faster by walking the list only once
  771. Revision 1.44 2002/11/22 22:48:10 carl
  772. * memory optimization with tconstsym (1.5%)
  773. Revision 1.43 2002/10/05 12:43:25 carl
  774. * fixes for Delphi 6 compilation
  775. (warning : Some features do not work under Delphi)
  776. Revision 1.42 2002/09/07 15:25:03 peter
  777. * old logs removed and tabs fixed
  778. Revision 1.41 2002/09/07 12:16:04 carl
  779. * second part bug report 1996 fix, testrange in cordconstnode
  780. only called if option is set (also make parsing a tiny faster)
  781. Revision 1.40 2002/08/22 11:21:44 florian
  782. + register32 is now written by tnode.dowrite
  783. * fixed write of value of tconstnode
  784. Revision 1.39 2002/08/18 20:06:23 peter
  785. * inlining is now also allowed in interface
  786. * renamed write/load to ppuwrite/ppuload
  787. * tnode storing in ppu
  788. * nld,ncon,nbas are already updated for storing in ppu
  789. Revision 1.38 2002/08/17 22:09:45 florian
  790. * result type handling in tcgcal.pass_2 overhauled
  791. * better tnode.dowrite
  792. * some ppc stuff fixed
  793. Revision 1.37 2002/07/23 12:34:30 daniel
  794. * Readded old set code. To use it define 'oldset'. Activated by default
  795. for ppc.
  796. Revision 1.36 2002/07/22 11:48:04 daniel
  797. * Sets are now internally sets.
  798. Revision 1.35 2002/07/20 11:57:54 florian
  799. * types.pas renamed to defbase.pas because D6 contains a types
  800. unit so this would conflicts if D6 programms are compiled
  801. + Willamette/SSE2 instructions to assembler added
  802. Revision 1.34 2002/07/14 18:00:43 daniel
  803. + Added the beginning of a state tracker. This will track the values of
  804. variables through procedures and optimize things away.
  805. Revision 1.33 2002/07/01 18:46:23 peter
  806. * internal linker
  807. * reorganized aasm layer
  808. Revision 1.32 2002/05/18 13:34:09 peter
  809. * readded missing revisions
  810. Revision 1.31 2002/05/16 19:46:37 carl
  811. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  812. + try to fix temp allocation (still in ifdef)
  813. + generic constructor calls
  814. + start of tassembler / tmodulebase class cleanup
  815. Revision 1.29 2002/05/12 16:53:07 peter
  816. * moved entry and exitcode to ncgutil and cgobj
  817. * foreach gets extra argument for passing local data to the
  818. iterator function
  819. * -CR checks also class typecasts at runtime by changing them
  820. into as
  821. * fixed compiler to cycle with the -CR option
  822. * fixed stabs with elf writer, finally the global variables can
  823. be watched
  824. * removed a lot of routines from cga unit and replaced them by
  825. calls to cgobj
  826. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  827. u32bit then the other is typecasted also to u32bit without giving
  828. a rangecheck warning/error.
  829. * fixed pascal calling method with reversing also the high tree in
  830. the parast, detected by tcalcst3 test
  831. Revision 1.28 2002/04/07 13:25:20 carl
  832. + change unit use
  833. Revision 1.27 2002/04/04 19:05:58 peter
  834. * removed unused units
  835. * use tlocation.size in cg.a_*loc*() routines
  836. Revision 1.26 2002/04/02 17:11:29 peter
  837. * tlocation,treference update
  838. * LOC_CONSTANT added for better constant handling
  839. * secondadd splitted in multiple routines
  840. * location_force_reg added for loading a location to a register
  841. of a specified size
  842. * secondassignment parses now first the right and then the left node
  843. (this is compatible with Kylix). This saves a lot of push/pop especially
  844. with string operations
  845. * adapted some routines to use the new cg methods
  846. Revision 1.25 2002/03/04 19:10:11 peter
  847. * removed compiler warnings
  848. }