1 {
2     Copyright (c) 2000-2002 by Florian Klaempfl
3 
4     Type checking and register allocation for constants
5 
6     This program is free software; you can redistribute it and/or modify
7     it under the terms of the GNU General Public License as published by
8     the Free Software Foundation; either version 2 of the License, or
9     (at your option) any later version.
10 
11     This program is distributed in the hope that it will be useful,
12     but WITHOUT ANY WARRANTY; without even the implied warranty of
13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14     GNU General Public License for more details.
15 
16     You should have received a copy of the GNU General Public License
17     along with this program; if not, write to the Free Software
18     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19 
20  ****************************************************************************
21 }
22 unit ncon;
23 
24 {$i fpcdefs.inc}
25 
26 interface
27 
28     uses
29       globtype,widestr,constexp,
30       node,
31       aasmbase,cpuinfo,globals,
32       symconst,symtype,symdef,symsym;
33 
34     type
35        trealconstnode = class(tnode)
36           typedef : tdef;
37           typedefderef : tderef;
38           value_real : bestreal;
39           value_currency : currency;
40           lab_real : tasmlabel;
41           constructor create(v : bestreal;def:tdef);virtual;
42           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
43           procedure ppuwrite(ppufile:tcompilerppufile);override;
44           procedure buildderefimpl;override;
45           procedure derefimpl;override;
dogetcopynull46           function dogetcopy : tnode;override;
pass_1null47           function pass_1 : tnode;override;
pass_typechecknull48           function pass_typecheck:tnode;override;
docomparenull49           function docompare(p: tnode) : boolean; override;
50           procedure printnodedata(var t:text);override;
51        end;
52        trealconstnodeclass = class of trealconstnode;
53 
54        tordconstnode = class(tnode)
55           typedef : tdef;
56           typedefderef : tderef;
57           value : TConstExprInt;
58           rangecheck : boolean;
59           { create an ordinal constant node of the specified type and value.
60             _rangecheck determines if the value of the ordinal should be checked
61             against the ranges of the type definition.
62           }
63           constructor create(const v : tconstexprint;def:tdef; _rangecheck : boolean);virtual;
64           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
65           procedure ppuwrite(ppufile:tcompilerppufile);override;
66           procedure buildderefimpl;override;
67           procedure derefimpl;override;
dogetcopynull68           function dogetcopy : tnode;override;
pass_1null69           function pass_1 : tnode;override;
pass_typechecknull70           function pass_typecheck:tnode;override;
docomparenull71           function docompare(p: tnode) : boolean; override;
72           procedure printnodedata(var t:text);override;
73        end;
74        tordconstnodeclass = class of tordconstnode;
75 
76        tpointerconstnode = class(tnode)
77           typedef : tdef;
78           typedefderef : tderef;
79           value   : TConstPtrUInt;
80           constructor create(v : TConstPtrUInt;def:tdef);virtual;
81           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
82           procedure ppuwrite(ppufile:tcompilerppufile);override;
83           procedure buildderefimpl;override;
84           procedure derefimpl;override;
dogetcopynull85           function dogetcopy : tnode;override;
pass_1null86           function pass_1 : tnode;override;
pass_typechecknull87           function pass_typecheck:tnode;override;
docomparenull88           function docompare(p: tnode) : boolean; override;
89           procedure printnodedata(var t : text); override;
90        end;
91        tpointerconstnodeclass = class of tpointerconstnode;
92 
93        tconststringtype = (
94          cst_conststring,
95          cst_shortstring,
96          cst_longstring,
97          cst_ansistring,
98          cst_widestring,
99          cst_unicodestring
100        );
101 
102        tstringconstnode = class(tnode)
103           value_str : pchar;
104           len     : longint;
105           lab_str : tasmlabel;
106           astringdef : tdef;
107           astringdefderef : tderef;
108           cst_type : tconststringtype;
109           constructor createstr(const s : string);virtual;
110           constructor createpchar(s: pchar; l: longint; def: tdef);virtual;
111           constructor createunistr(w : pcompilerwidestring);virtual;
112           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
113           procedure ppuwrite(ppufile:tcompilerppufile);override;
114           procedure buildderefimpl;override;
115           procedure derefimpl;override;
116           destructor destroy;override;
dogetcopynull117           function dogetcopy : tnode;override;
pass_1null118           function pass_1 : tnode;override;
pass_typechecknull119           function pass_typecheck:tnode;override;
getpcharcopynull120           function getpcharcopy : pchar;
docomparenull121           function docompare(p: tnode) : boolean; override;
122           procedure changestringtype(def:tdef);
fullcomparenull123           function fullcompare(p: tstringconstnode): longint;
124           { returns whether this platform uses the nil pointer to represent
125             empty dynamic strings }
emptydynstrnilnull126           class function emptydynstrnil: boolean; virtual;
127        end;
128        tstringconstnodeclass = class of tstringconstnode;
129 
130        tsetconstnode = class(tunarynode)
131           typedef : tdef;
132           typedefderef : tderef;
133           value_set : pconstset;
134           lab_set : tasmsymbol;
135           constructor create(s : pconstset;def:tdef);virtual;
136           destructor destroy;override;
137           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
138           procedure ppuwrite(ppufile:tcompilerppufile);override;
139           procedure buildderefimpl;override;
140           procedure derefimpl;override;
141           procedure adjustforsetbase;
dogetcopynull142           function dogetcopy : tnode;override;
pass_1null143           function pass_1 : tnode;override;
pass_typechecknull144           function pass_typecheck:tnode;override;
docomparenull145           function docompare(p: tnode) : boolean; override;
elementsnull146           function elements : AInt;
147        end;
148        tsetconstnodeclass = class of tsetconstnode;
149 
150        tnilnode = class(tnode)
151           constructor create;virtual;
pass_1null152           function pass_1 : tnode;override;
pass_typechecknull153           function pass_typecheck:tnode;override;
154        end;
155        tnilnodeclass = class of tnilnode;
156 
157        tguidconstnode = class(tnode)
158           value : tguid;
159           lab_set : tasmsymbol;
160           constructor create(const g:tguid);virtual;
161           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
162           procedure ppuwrite(ppufile:tcompilerppufile);override;
dogetcopynull163           function dogetcopy : tnode;override;
pass_1null164           function pass_1 : tnode;override;
pass_typechecknull165           function pass_typecheck:tnode;override;
docomparenull166           function docompare(p: tnode) : boolean; override;
167        end;
168        tguidconstnodeclass = class of tguidconstnode;
169 
170     var
171        crealconstnode : trealconstnodeclass = trealconstnode;
172        cordconstnode : tordconstnodeclass = tordconstnode;
173        cpointerconstnode : tpointerconstnodeclass = tpointerconstnode;
174        cstringconstnode : tstringconstnodeclass = tstringconstnode;
175        csetconstnode : tsetconstnodeclass = tsetconstnode;
176        cguidconstnode : tguidconstnodeclass = tguidconstnode;
177        cnilnode : tnilnodeclass=tnilnode;
178 
genintconstnodenull179     function genintconstnode(const v : TConstExprInt) : tordconstnode;
genenumnodenull180     function genenumnode(v : tenumsym) : tordconstnode;
181 
182     { some helper routines }
get_ordinal_valuenull183     function get_ordinal_value(p : tnode) : TConstExprInt;
get_string_valuenull184     function get_string_value(p : tnode; def: tstringdef) : tstringconstnode;
is_constresourcestringnodenull185     function is_constresourcestringnode(p : tnode) : boolean;
is_emptysetnull186     function is_emptyset(p : tnode):boolean;
genconstsymtreenull187     function genconstsymtree(p : tconstsym) : tnode;
188 
getbooleanvaluenull189     function getbooleanvalue(p : tnode) : boolean;
190 
191 implementation
192 
193     uses
194       cutils,
195       verbose,systems,sysutils,
196       defcmp,defutil,procinfo,
197       cgbase,
198       nld;
199 
genintconstnodenull200     function genintconstnode(const v : TConstExprInt) : tordconstnode;
201       var
202         htype : tdef;
203       begin
204          int_to_type(v,htype);
205          genintconstnode:=cordconstnode.create(v,htype,true);
206       end;
207 
208 
genenumnodenull209     function genenumnode(v : tenumsym) : tordconstnode;
210       var
211         htype : tdef;
212       begin
213          htype:=v.definition;
214          genenumnode:=cordconstnode.create(int64(v.value),htype,true);
215       end;
216 
217 
get_ordinal_valuenull218     function get_ordinal_value(p : tnode) : TConstExprInt;
219       begin
220         get_ordinal_value:=0;
221         if is_constnode(p) then
222           begin
223             if p.nodetype=ordconstn then
224               get_ordinal_value:=tordconstnode(p).value
225             else
226               Message(type_e_ordinal_expr_expected);
227           end
228         else
229           Message(type_e_constant_expr_expected);
230       end;
231 
get_string_valuenull232     function get_string_value(p: tnode; def: tstringdef): tstringconstnode;
233       var
234         stringVal: string;
235         pWideStringVal: pcompilerwidestring;
236       begin
237         stringVal:='';
238         if is_constcharnode(p) then
239           begin
240             SetLength(stringVal,1);
241             stringVal[1]:=char(tordconstnode(p).value.uvalue);
242             result:=cstringconstnode.createstr(stringVal);
243           end
244         else if is_constwidecharnode(p) then
245           begin
246             initwidestring(pWideStringVal);
247             concatwidestringchar(pWideStringVal, tcompilerwidechar(tordconstnode(p).value.uvalue));
248             result:=cstringconstnode.createunistr(pWideStringVal);
249           end
250         else if p.nodetype=stringconstn then
251           result:=tstringconstnode(p.getcopy)
252         else
253           begin
254             Message(type_e_string_expr_expected);
255             stringVal:='';
256             result:=cstringconstnode.createstr(stringVal);
257           end;
258         result.changestringtype(def);
259       end;
260 
261 
is_constresourcestringnodenull262     function is_constresourcestringnode(p : tnode) : boolean;
263       begin
264         is_constresourcestringnode:=(p.nodetype=loadn) and
265           (tloadnode(p).symtableentry.typ=constsym) and
266           (tconstsym(tloadnode(p).symtableentry).consttyp=constresourcestring);
267       end;
268 
269 
is_emptysetnull270     function is_emptyset(p : tnode):boolean;
271       begin
272         is_emptyset:=(p.nodetype=setconstn) and
273                      (Tsetconstnode(p).value_set^=[]);
274       end;
275 
276 
genconstsymtreenull277     function genconstsymtree(p : tconstsym) : tnode;
278       var
279         p1  : tnode;
280         len : longint;
281         pc  : pchar;
282       begin
283         p1:=nil;
284         case p.consttyp of
285           constord :
286             begin
287               if p.constdef=nil then
288                 internalerror(200403232);
289               p1:=cordconstnode.create(p.value.valueord,p.constdef,true);
290             end;
291           conststring :
292             begin
293               len:=p.value.len;
294               if not(cs_refcountedstrings in current_settings.localswitches) and (len>255) then
295                 begin
296                   message(parser_e_string_const_too_long);
297                   len:=255;
298                 end;
299               getmem(pc,len+1);
300               move(pchar(p.value.valueptr)^,pc^,len);
301               pc[len]:=#0;
302               p1:=cstringconstnode.createpchar(pc,len,p.constdef);
303             end;
304           constwstring :
305             p1:=cstringconstnode.createunistr(pcompilerwidestring(p.value.valueptr));
306           constreal :
307             p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,p.constdef);
308           constset :
309             p1:=csetconstnode.create(pconstset(p.value.valueptr),p.constdef);
310           constpointer :
311             p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef);
312           constnil :
313             p1:=cnilnode.create;
314           constguid :
315             p1:=cguidconstnode.create(pguid(p.value.valueptr)^);
316           else
317             internalerror(200205103);
318         end;
319         genconstsymtree:=p1;
320       end;
321 
322 
getbooleanvaluenull323     function getbooleanvalue(p : tnode) : boolean;
324       begin
325         if is_constboolnode(p) then
326           result:=tordconstnode(p).value<>0
327         else
328           internalerror(2013111601);
329       end;
330 
331 {*****************************************************************************
332                              TREALCONSTNODE
333 *****************************************************************************}
334 
335     { generic code     }
336     { overridden by:   }
337     {   i386           }
338     constructor trealconstnode.create(v : bestreal;def:tdef);
339       begin
340          if current_settings.fputype=fpu_none then
341             internalerror(2008022401);
342          inherited create(realconstn);
343          typedef:=def;
344          case tfloatdef(def).floattype of
345            s32real:
346              v:=single(v);
347            s64real:
348              v:=double(v);
349            s80real,
350            sc80real,
351            s64comp,
352            s64currency:
353              v:=extended(v);
354            s128real:
355              internalerror(2013102701);
356            else
357              internalerror(2013102702);
358          end;
359          value_real:=v;
360          value_currency:=v;
361          lab_real:=nil;
362       end;
363 
364     constructor trealconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
365       var
366         i : int64;
367       begin
368         inherited ppuload(t,ppufile);
369         ppufile.getderef(typedefderef);
370         value_real:=ppufile.getreal;
371         i:=ppufile.getint64;
372         value_currency:=PCurrency(@i)^;
373         lab_real:=tasmlabel(ppufile.getasmsymbol);
374       end;
375 
376 
377     procedure trealconstnode.ppuwrite(ppufile:tcompilerppufile);
378       begin
379         inherited ppuwrite(ppufile);
380         ppufile.putderef(typedefderef);
381         ppufile.putreal(value_real);
382         ppufile.putint64(PInt64(@value_currency)^);
383         ppufile.putasmsymbol(lab_real);
384       end;
385 
386 
387     procedure trealconstnode.buildderefimpl;
388       begin
389         inherited buildderefimpl;
390         typedefderef.build(typedef);
391       end;
392 
393 
394     procedure trealconstnode.derefimpl;
395       begin
396         inherited derefimpl;
397         typedef:=tdef(typedefderef.resolve);
398       end;
399 
400 
trealconstnode.dogetcopynull401     function trealconstnode.dogetcopy : tnode;
402       var
403          n : trealconstnode;
404       begin
405          n:=trealconstnode(inherited dogetcopy);
406          n.typedef:=typedef;
407          n.value_real:=value_real;
408          n.value_currency:=value_currency;
409          n.lab_real:=lab_real;
410          dogetcopy:=n;
411       end;
412 
413 
trealconstnode.pass_typechecknull414     function trealconstnode.pass_typecheck:tnode;
415       begin
416         result:=nil;
417         resultdef:=typedef;
418 
419         { range checking? }
420         if floating_point_range_check_error or
421            (tfloatdef(resultdef).floattype in [s64comp,s64currency]) then
422           begin
423             { use CGMessage so that the resultdef will get set to errordef
424               by pass1.typecheckpass_internal if a range error was triggered,
425               which in turn will prevent any potential parent type conversion
426               node from creating a new realconstnode with this exact same value
427               and hence trigger the same error again }
428             case tfloatdef(resultdef).floattype of
429               s32real :
430                 begin
431                   if ts32real(value_real)=MathInf.Value then
432                     CGMessage(parser_e_range_check_error);
433                 end;
434               s64real:
435                 begin
436                   if ts64real(value_real)=MathInf.Value then
437                     CGMessage(parser_e_range_check_error);
438                 end;
439               s80real,
440               sc80real:
441                 begin
442                   if ts80real(value_real)=MathInf.Value then
443                     CGMessage(parser_e_range_check_error);
444                 end;
445               s64comp,
446               s64currency:
447                 begin
448                   if (value_real>9223372036854775807.0) or
449                      (value_real<-9223372036854775808.0) then
450                     CGMessage(parser_e_range_check_error)
451                 end;
452               s128real:
453                 begin
454                   if ts128real(value_real)=MathInf.Value then
455                     CGMessage(parser_e_range_check_error);
456                 end;
457               else
458                 internalerror(2016112902);
459             end;
460           end;
461       end;
462 
463 
trealconstnode.pass_1null464     function trealconstnode.pass_1 : tnode;
465       begin
466          result:=nil;
467          expectloc:=LOC_CREFERENCE;
468          if (cs_create_pic in current_settings.moduleswitches) then
469            include(current_procinfo.flags,pi_needs_got);
470       end;
471 
472 
trealconstnode.docomparenull473     function trealconstnode.docompare(p: tnode): boolean;
474       begin
475         docompare :=
476           inherited docompare(p) and
477           { this should be always true }
478           (trealconstnode(p).typedef.typ=floatdef) and (typedef.typ=floatdef) and
479           (tfloatdef(typedef).floattype = tfloatdef(trealconstnode(p).typedef).floattype) and
480           (
481            (
482             (tfloatdef(typedef).floattype=s64currency) and
483             (value_currency=trealconstnode(p).value_currency)
484            )
485            or
486            (
487             (tfloatdef(typedef).floattype<>s64currency) and
488             (value_real = trealconstnode(p).value_real) and
489             { floating point compares for non-numbers give strange results usually }
490             is_number_float(value_real) and
491             is_number_float(trealconstnode(p).value_real)
492            )
493           );
494       end;
495 
496 
497     procedure Trealconstnode.printnodedata(var t:text);
498       begin
499         inherited printnodedata(t);
500         write(t,printnodeindention,'value = ',value_real);
501         if is_currency(resultdef) then
502           writeln(', value_currency = ',value_currency)
503         else
504           writeln;
505       end;
506 
507 
508 {*****************************************************************************
509                               TORDCONSTNODE
510 *****************************************************************************}
511 
512     constructor tordconstnode.create(const v : tconstexprint;def:tdef;_rangecheck : boolean);
513 
514       begin
515          inherited create(ordconstn);
516          value:=v;
517          typedef:=def;
518          rangecheck := _rangecheck;
519       end;
520 
521 
522     constructor tordconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
523       begin
524         inherited ppuload(t,ppufile);
525         ppufile.getderef(typedefderef);
526         value:=ppufile.getexprint;
527         { normally, the value is already compiled, so we don't need
528           to do once again a range check
529         }
530         rangecheck := false;
531       end;
532 
533 
534     procedure tordconstnode.ppuwrite(ppufile:tcompilerppufile);
535       begin
536         inherited ppuwrite(ppufile);
537         ppufile.putderef(typedefderef);
538         ppufile.putexprint(value);
539       end;
540 
541 
542     procedure tordconstnode.buildderefimpl;
543       begin
544         inherited buildderefimpl;
545         typedefderef.build(typedef);
546       end;
547 
548 
549     procedure tordconstnode.derefimpl;
550       begin
551         inherited derefimpl;
552         typedef:=tdef(typedefderef.resolve);
553       end;
554 
555 
tordconstnode.dogetcopynull556     function tordconstnode.dogetcopy : tnode;
557 
558       var
559          n : tordconstnode;
560 
561       begin
562          n:=tordconstnode(inherited dogetcopy);
563          n.value:=value;
564          n.typedef := typedef;
565          dogetcopy:=n;
566       end;
567 
tordconstnode.pass_typechecknull568     function tordconstnode.pass_typecheck:tnode;
569       begin
570         result:=nil;
571         resultdef:=typedef;
572         { only do range checking when explicitly asked for it
573           and if the type can be range checked, see tests/tbs/tb0539.pp }
574         if (resultdef.typ in [orddef,enumdef]) then
575           adaptrange(resultdef,value,nf_internal in flags,not rangecheck,rangecheck)
576       end;
577 
tordconstnode.pass_1null578     function tordconstnode.pass_1 : tnode;
579       begin
580          result:=nil;
581          expectloc:=LOC_CONSTANT;
582       end;
583 
tordconstnode.docomparenull584     function tordconstnode.docompare(p: tnode): boolean;
585       begin
586         docompare :=
587           inherited docompare(p) and
588           (value = tordconstnode(p).value) and
589           equal_defs(typedef,tordconstnode(p).typedef);
590       end;
591 
592 
593     procedure Tordconstnode.printnodedata(var t:text);
594       begin
595         inherited printnodedata(t);
596         writeln(t,printnodeindention,'value = ',tostr(value));
597       end;
598 
599 
600 {*****************************************************************************
601                             TPOINTERCONSTNODE
602 *****************************************************************************}
603 
604     constructor tpointerconstnode.create(v : TConstPtrUInt;def:tdef);
605 
606       begin
607          inherited create(pointerconstn);
608          value:=v;
609          typedef:=def;
610       end;
611 
612 
613     constructor tpointerconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
614       begin
615         inherited ppuload(t,ppufile);
616         ppufile.getderef(typedefderef);
617         value:=ppufile.getptruint;
618       end;
619 
620 
621     procedure tpointerconstnode.ppuwrite(ppufile:tcompilerppufile);
622       begin
623         inherited ppuwrite(ppufile);
624         ppufile.putderef(typedefderef);
625         ppufile.putptruint(value);
626       end;
627 
628 
629     procedure tpointerconstnode.buildderefimpl;
630       begin
631         inherited buildderefimpl;
632         typedefderef.build(typedef);
633       end;
634 
635 
636     procedure tpointerconstnode.derefimpl;
637       begin
638         inherited derefimpl;
639         typedef:=tdef(typedefderef.resolve);
640       end;
641 
642 
tpointerconstnode.dogetcopynull643     function tpointerconstnode.dogetcopy : tnode;
644 
645       var
646          n : tpointerconstnode;
647 
648       begin
649          n:=tpointerconstnode(inherited dogetcopy);
650          n.value:=value;
651          n.typedef := typedef;
652          dogetcopy:=n;
653       end;
654 
tpointerconstnode.pass_typechecknull655     function tpointerconstnode.pass_typecheck:tnode;
656       begin
657         result:=nil;
658         resultdef:=typedef;
659       end;
660 
tpointerconstnode.pass_1null661     function tpointerconstnode.pass_1 : tnode;
662       begin
663          result:=nil;
664          expectloc:=LOC_CONSTANT;
665       end;
666 
tpointerconstnode.docomparenull667     function tpointerconstnode.docompare(p: tnode): boolean;
668       begin
669         docompare :=
670           inherited docompare(p) and
671           (value = tpointerconstnode(p).value);
672       end;
673 
674 
675     procedure tpointerconstnode.printnodedata(var t : text);
676       begin
677         inherited printnodedata(t);
678         writeln(t,printnodeindention,'value = $',hexstr(PUInt(value),sizeof(PUInt)*2));
679       end;
680 
681 
682 {*****************************************************************************
683                              TSTRINGCONSTNODE
684 *****************************************************************************}
685 
686     constructor tstringconstnode.createstr(const s : string);
687       var
688          l : longint;
689       begin
690          inherited create(stringconstn);
691          l:=length(s);
692          len:=l;
693          { stringdup write even past a #0 }
694          getmem(value_str,l+1);
695          move(s[1],value_str^,l);
696          value_str[l]:=#0;
697          lab_str:=nil;
698          cst_type:=cst_conststring;
699       end;
700 
701 
702     constructor tstringconstnode.createunistr(w : pcompilerwidestring);
703       begin
704          inherited create(stringconstn);
705          len:=getlengthwidestring(w);
706          initwidestring(pcompilerwidestring(value_str));
707          copywidestring(w,pcompilerwidestring(value_str));
708          lab_str:=nil;
709          cst_type:=cst_unicodestring;
710       end;
711 
712 
713     constructor tstringconstnode.createpchar(s: pchar; l: longint; def: tdef);
714       begin
715          inherited create(stringconstn);
716          len:=l;
717          value_str:=s;
718          if assigned(def) and
719             is_ansistring(def) then
720            begin
721              cst_type:=cst_ansistring;
722              astringdef:=def;
723            end
724          else
725            cst_type:=cst_conststring;
726          lab_str:=nil;
727       end;
728 
729 
730     destructor tstringconstnode.destroy;
731       begin
732         if cst_type in [cst_widestring,cst_unicodestring] then
733           donewidestring(pcompilerwidestring(value_str))
734         else
735           ansistringdispose(value_str,len);
736         inherited destroy;
737       end;
738 
739 
740     constructor tstringconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
741       var
742         pw : pcompilerwidestring;
743         i : longint;
744       begin
745         inherited ppuload(t,ppufile);
746         cst_type:=tconststringtype(ppufile.getbyte);
747         len:=ppufile.getlongint;
748         if cst_type in [cst_widestring,cst_unicodestring] then
749           begin
750             initwidestring(pw);
751             setlengthwidestring(pw,len);
752             { don't use getdata, because the compilerwidechars may have to
753               be byteswapped
754             }
755 {$if sizeof(tcompilerwidechar) = 2}
756             for i:=0 to pw^.len-1 do
757               pw^.data[i]:=ppufile.getword;
758 {$elseif sizeof(tcompilerwidechar) = 4}
759             for i:=0 to pw^.len-1 do
760               pw^.data[i]:=cardinal(ppufile.getlongint);
761 {$else}
762            {$error Unsupported tcompilerwidechar size}
763 {$endif}
764             pcompilerwidestring(value_str):=pw
765           end
766         else
767           begin
768             getmem(value_str,len+1);
769             ppufile.getdata(value_str^,len);
770             value_str[len]:=#0;
771           end;
772         lab_str:=tasmlabel(ppufile.getasmsymbol);
773         if cst_type=cst_ansistring then
774           ppufile.getderef(astringdefderef);
775       end;
776 
777 
778     procedure tstringconstnode.ppuwrite(ppufile:tcompilerppufile);
779       begin
780         inherited ppuwrite(ppufile);
781         ppufile.putbyte(byte(cst_type));
782         ppufile.putlongint(len);
783         if cst_type in [cst_widestring,cst_unicodestring] then
784           ppufile.putdata(pcompilerwidestring(value_str)^.data^,len*sizeof(tcompilerwidechar))
785         else
786           ppufile.putdata(value_str^,len);
787         ppufile.putasmsymbol(lab_str);
788         if cst_type=cst_ansistring then
789           ppufile.putderef(astringdefderef);
790       end;
791 
792 
793     procedure tstringconstnode.buildderefimpl;
794       begin
795         inherited buildderefimpl;
796         if cst_type=cst_ansistring then
797           astringdefderef.build(astringdef);
798       end;
799 
800 
801     procedure tstringconstnode.derefimpl;
802       begin
803         inherited derefimpl;
804         if cst_type=cst_ansistring then
805           astringdef:=tdef(astringdefderef.resolve);
806       end;
807 
808 
tstringconstnode.dogetcopynull809     function tstringconstnode.dogetcopy : tnode;
810 
811       var
812          n : tstringconstnode;
813 
814       begin
815          n:=tstringconstnode(inherited dogetcopy);
816          n.cst_type:=cst_type;
817          n.len:=len;
818          n.lab_str:=lab_str;
819          if cst_type in [cst_widestring,cst_unicodestring] then
820            begin
821              initwidestring(pcompilerwidestring(n.value_str));
822              copywidestring(pcompilerwidestring(value_str),pcompilerwidestring(n.value_str));
823            end
824          else
825            n.value_str:=getpcharcopy;
826          n.astringdef:=astringdef;
827          dogetcopy:=n;
828       end;
829 
tstringconstnode.pass_typechecknull830     function tstringconstnode.pass_typecheck:tnode;
831       var
832         l : aint;
833       begin
834         result:=nil;
835         case cst_type of
836           cst_conststring :
837             begin
838               { handle and store as array[0..len-1] of char }
839               if len>0 then
840                 l:=len-1
841               else
842                 l:=0;
843               resultdef:=carraydef.create(0,l,s32inttype);
844               tarraydef(resultdef).elementdef:=cansichartype;
845               include(tarraydef(resultdef).arrayoptions,ado_IsConstString);
846             end;
847           cst_shortstring :
848             resultdef:=cshortstringtype;
849           cst_ansistring :
850             if not assigned(astringdef) then
851               resultdef:=getansistringdef
852             else
853               resultdef:=astringdef;
854           cst_unicodestring :
855             resultdef:=cunicodestringtype;
856           cst_widestring :
857             resultdef:=cwidestringtype;
858           cst_longstring :
859             resultdef:=clongstringtype;
860         end;
861       end;
862 
tstringconstnode.pass_1null863     function tstringconstnode.pass_1 : tnode;
864       begin
865         result:=nil;
866         if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then
867           begin
868             if len=0 then
869               expectloc:=LOC_CONSTANT
870             else
871               expectloc:=LOC_REGISTER
872           end
873         else
874           expectloc:=LOC_CREFERENCE;
875         if (cs_create_pic in current_settings.moduleswitches) and
876            (expectloc <> LOC_CONSTANT) then
877           include(current_procinfo.flags,pi_needs_got);
878       end;
879 
880 
tstringconstnode.getpcharcopynull881     function tstringconstnode.getpcharcopy : pchar;
882       var
883          pc : pchar;
884       begin
885          pc:=nil;
886          getmem(pc,len+1);
887          if pc=nil then
888            Message(general_f_no_memory_left);
889          move(value_str^,pc^,len+1);
890          getpcharcopy:=pc;
891       end;
892 
tstringconstnode.docomparenull893     function tstringconstnode.docompare(p: tnode): boolean;
894       begin
895         docompare :=
896           inherited docompare(p) and
897           (len = tstringconstnode(p).len) and
898           (lab_str = tstringconstnode(p).lab_str) and
899           { This is enough as soon as labels are allocated, otherwise }
900           { fall back to content compare.                             }
901           (assigned(lab_str) or
902             (cst_type = tstringconstnode(p).cst_type) and
903             (fullcompare(tstringconstnode(p)) = 0))
904           ;
905       end;
906 
907 
908     procedure tstringconstnode.changestringtype(def:tdef);
909       const
910         st2cst : array[tstringtype] of tconststringtype = (
911           cst_shortstring,cst_longstring,cst_ansistring,cst_widestring,cst_unicodestring);
912       var
913         pw : pcompilerwidestring;
914         pc : pchar;
915         cp1 : tstringencoding;
916         cp2 : tstringencoding;
917         l,l2 : longint;
918       begin
919         if def.typ<>stringdef then
920           internalerror(200510011);
921         { convert ascii 2 unicode }
922         if (tstringdef(def).stringtype in [st_widestring,st_unicodestring]) and
923            not(cst_type in [cst_widestring,cst_unicodestring]) then
924           begin
925             initwidestring(pw);
926             ascii2unicode(value_str,len,current_settings.sourcecodepage,pw);
927             ansistringdispose(value_str,len);
928             pcompilerwidestring(value_str):=pw;
929           end
930         else
931           { convert unicode 2 ascii }
932           if (cst_type in [cst_widestring,cst_unicodestring]) and
933             not(tstringdef(def).stringtype in [st_widestring,st_unicodestring]) then
934             begin
935               cp1:=tstringdef(def).encoding;
936               if (cp1=globals.CP_NONE) or (cp1=0) then
937                 cp1:=current_settings.sourcecodepage;
938               if (cp1=CP_UTF8) then
939                 begin
940                   pw:=pcompilerwidestring(value_str);
941                   l2:=len;
942                   l:=UnicodeToUtf8(nil,0,PUnicodeChar(pw^.data),l2);
943                   getmem(pc,l);
944                   UnicodeToUtf8(pc,l,PUnicodeChar(pw^.data),l2);
945                   len:=l-1;
946                   donewidestring(pw);
947                   value_str:=pc;
948                 end
949               else
950                 begin
951                   pw:=pcompilerwidestring(value_str);
952                   getmem(pc,getlengthwidestring(pw)+1);
953                   unicode2ascii(pw,pc,cp1);
954                   donewidestring(pw);
955                   value_str:=pc;
956                 end;
957             end
958         else
959           if (tstringdef(def).stringtype = st_ansistring) and
960              not(cst_type in [cst_widestring,cst_unicodestring]) then
961             begin
962               cp1:=tstringdef(def).encoding;
963               if cp1=0 then
964                 cp1:=current_settings.sourcecodepage;
965               if (cst_type = cst_ansistring) then
966                 begin
967                   cp2:=tstringdef(resultdef).encoding;
968                   if cp2=0 then
969                     cp2:=current_settings.sourcecodepage;
970                 end
971               else if (cst_type in [cst_shortstring,cst_conststring,cst_longstring]) then
972                 cp2:=current_settings.sourcecodepage
973               else
974                 internalerror(2013112916);
975               { don't change string if codepages are equal or string length is 0 }
976               if (cp1<>cp2) and (len>0) then
977                 begin
978                   if cpavailable(cp1) and cpavailable(cp2) then
979                     changecodepage(value_str,len,cp2,value_str,cp1)
980                   else if (cp1 <> globals.CP_NONE) and (cp2 <> globals.CP_NONE) then
981                     begin
982                       { if source encoding is UTF8 convert using UTF8->UTF16->destination encoding }
983                       if (cp2=CP_UTF8) then
984                         begin
985                           if not cpavailable(cp1) then
986                             Message1(option_code_page_not_available,IntToStr(cp1));
987                           initwidestring(pw);
988                           setlengthwidestring(pw,len);
989                           { returns room for terminating 0 }
990                           l:=Utf8ToUnicode(PUnicodeChar(pw^.data),len,value_str,len);
991                           if (l<>getlengthwidestring(pw)) then
992                             begin
993                               setlengthwidestring(pw,l);
994                               ReAllocMem(value_str,l);
995                             end;
996                           unicode2ascii(pw,value_str,cp1);
997                           len:=l-1;
998                           donewidestring(pw);
999                         end
1000                       else
1001                       { if destination encoding is UTF8 convert using source encoding->UTF16->UTF8 }
1002                       if (cp1=CP_UTF8) then
1003                         begin
1004                           if not cpavailable(cp2) then
1005                             Message1(option_code_page_not_available,IntToStr(cp2));
1006                           initwidestring(pw);
1007                           setlengthwidestring(pw,len);
1008                           ascii2unicode(value_str,len,cp2,pw);
1009                           { returns room for terminating 0 }
1010                           l:=UnicodeToUtf8(nil,0,PUnicodeChar(pw^.data),len);
1011                           if l<>len then
1012                             ReAllocMem(value_str,l);
1013                           len:=l-1;
1014                           UnicodeToUtf8(value_str,PUnicodeChar(pw^.data),l);
1015                           donewidestring(pw);
1016                         end
1017                       else
1018                         begin
1019                           { output error message that encoding is not available for the compiler }
1020                           if not cpavailable(cp1) then
1021                             Message1(option_code_page_not_available,IntToStr(cp1));
1022                           if not cpavailable(cp2) then
1023                             Message1(option_code_page_not_available,IntToStr(cp2));
1024                         end;
1025                     end;
1026                 end;
1027             end;
1028         cst_type:=st2cst[tstringdef(def).stringtype];
1029         resultdef:=def;
1030       end;
1031 
tstringconstnode.fullcomparenull1032     function tstringconstnode.fullcompare(p: tstringconstnode): longint;
1033       begin
1034         if cst_type<>p.cst_type then
1035           InternalError(2009121701);
1036         if cst_type in [cst_widestring,cst_unicodestring] then
1037           result:=comparewidestrings(pcompilerwidestring(value_str),pcompilerwidestring(p.value_str))
1038         else
1039           result:=compareansistrings(value_str,p.value_str,len,p.len);
1040       end;
1041 
tstringconstnode.emptydynstrnilnull1042     class function tstringconstnode.emptydynstrnil: boolean;
1043       begin
1044         result:=true;
1045       end;
1046 
1047 {*****************************************************************************
1048                              TSETCONSTNODE
1049 *****************************************************************************}
1050 
1051     constructor tsetconstnode.create(s : pconstset;def:tdef);
1052 
1053       begin
1054          inherited create(setconstn,nil);
1055          typedef:=def;
1056          if assigned(s) then
1057            begin
1058               new(value_set);
1059               value_set^:=s^;
1060            end
1061          else
1062            value_set:=nil;
1063       end;
1064 
1065 
1066     destructor tsetconstnode.destroy;
1067       begin
1068         if assigned(value_set) then
1069          dispose(value_set);
1070         inherited destroy;
1071       end;
1072 
1073 
1074     constructor tsetconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
1075       begin
1076         inherited ppuload(t,ppufile);
1077         ppufile.getderef(typedefderef);
1078         new(value_set);
1079         ppufile.getnormalset(value_set^);
1080       end;
1081 
1082 
1083     procedure tsetconstnode.ppuwrite(ppufile:tcompilerppufile);
1084       begin
1085         inherited ppuwrite(ppufile);
1086         ppufile.putderef(typedefderef);
1087         ppufile.putnormalset(value_set^);
1088       end;
1089 
1090 
1091     procedure tsetconstnode.buildderefimpl;
1092       begin
1093         inherited buildderefimpl;
1094         typedefderef.build(typedef);
1095       end;
1096 
1097 
1098     procedure tsetconstnode.derefimpl;
1099       begin
1100         inherited derefimpl;
1101         typedef:=tdef(typedefderef.resolve);
1102       end;
1103 
1104     type
1105        setbytes = array[0..31] of byte;
1106        Psetbytes = ^setbytes;
1107 
1108     procedure tsetconstnode.adjustforsetbase;
1109       var
1110         i, diff: longint;
1111       begin
1112         { Internally, the compiler stores all sets with setbase 0, so we have }
1113         { to convert the set to its actual format in case setbase<>0 when     }
1114         { writing it out                                                      }
1115         if (tsetdef(resultdef).setbase<>0) then
1116           begin
1117             if (tsetdef(resultdef).setbase and 7)<>0 then
1118               internalerror(2007091501);
1119             diff:=tsetdef(resultdef).setbase div 8;
1120             { This is endian-neutral in the new set format: in both cases, }
1121             { the first byte contains the first elements of the set.       }
1122             { Since the compiler/base rtl cannot contain packed sets before }
1123             { they work for big endian, it's no problem that the code below }
1124             { is wrong for the old big endian set format (setbase cannot be }
1125             { <>0 with non-packed sets).                                    }
1126             for i:=0 to tsetdef(resultdef).size-1 do
1127               begin
1128                 Psetbytes(value_set)^[i]:=Psetbytes(value_set)^[i+diff];
1129                 Psetbytes(value_set)^[i+diff]:=0;
1130               end;
1131           end;
1132       end;
1133 
1134 
tsetconstnode.dogetcopynull1135     function tsetconstnode.dogetcopy : tnode;
1136       var
1137          n : tsetconstnode;
1138       begin
1139          n:=tsetconstnode(inherited dogetcopy);
1140          if assigned(value_set) then
1141            begin
1142               new(n.value_set);
1143               n.value_set^:=value_set^
1144            end
1145          else
1146            n.value_set:=nil;
1147          n.typedef := typedef;
1148          n.lab_set:=lab_set;
1149          dogetcopy:=n;
1150       end;
1151 
1152 
tsetconstnode.pass_typechecknull1153     function tsetconstnode.pass_typecheck:tnode;
1154       begin
1155         result:=nil;
1156         resultdef:=typedef;
1157       end;
1158 
1159 
tsetconstnode.pass_1null1160     function tsetconstnode.pass_1 : tnode;
1161       begin
1162          result:=nil;
1163          if is_smallset(resultdef) then
1164           expectloc:=LOC_CONSTANT
1165          else
1166           expectloc:=LOC_CREFERENCE;
1167         if (cs_create_pic in current_settings.moduleswitches) and
1168            (expectloc <> LOC_CONSTANT) then
1169           include(current_procinfo.flags,pi_needs_got);
1170       end;
1171 
1172 
tsetconstnode.docomparenull1173     function tsetconstnode.docompare(p: tnode): boolean;
1174       begin
1175         docompare:=(inherited docompare(p)) and
1176                    (value_set^=Tsetconstnode(p).value_set^);
1177       end;
1178 
1179 
tsetconstnode.elementsnull1180     function tsetconstnode.elements : AInt;
1181       var
1182         i : longint;
1183       begin
1184         result:=0;
1185         if not(assigned(value_set)) then
1186           exit;
1187         for i:=0 to tsetdef(resultdef).size-1 do
1188           result:=result+ PopCnt(Psetbytes(value_set)^[i]);
1189       end;
1190 
1191 
1192 {*****************************************************************************
1193                                TNILNODE
1194 *****************************************************************************}
1195 
1196     constructor tnilnode.create;
1197 
1198       begin
1199         inherited create(niln);
1200       end;
1201 
tnilnode.pass_typechecknull1202     function tnilnode.pass_typecheck:tnode;
1203       begin
1204         result:=nil;
1205         resultdef:=voidpointertype;
1206       end;
1207 
tnilnode.pass_1null1208     function tnilnode.pass_1 : tnode;
1209       begin
1210         result:=nil;
1211         expectloc:=LOC_CONSTANT;
1212       end;
1213 
1214 {*****************************************************************************
1215                             TGUIDCONSTNODE
1216 *****************************************************************************}
1217 
1218     constructor tguidconstnode.create(const g:tguid);
1219 
1220       begin
1221          inherited create(guidconstn);
1222          value:=g;
1223       end;
1224 
1225     constructor tguidconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
1226       begin
1227         inherited ppuload(t,ppufile);
1228         ppufile.getguid(value);
1229       end;
1230 
1231 
1232     procedure tguidconstnode.ppuwrite(ppufile:tcompilerppufile);
1233       begin
1234         inherited ppuwrite(ppufile);
1235         ppufile.putguid(value);
1236       end;
1237 
1238 
tguidconstnode.dogetcopynull1239     function tguidconstnode.dogetcopy : tnode;
1240       var
1241          n : tguidconstnode;
1242       begin
1243          n:=tguidconstnode(inherited dogetcopy);
1244          n.value:=value;
1245          n.lab_set:=lab_set;
1246          dogetcopy:=n;
1247       end;
1248 
1249 
tguidconstnode.pass_typechecknull1250     function tguidconstnode.pass_typecheck:tnode;
1251       begin
1252         result:=nil;
1253         resultdef:=rec_tguid;
1254       end;
1255 
1256 
tguidconstnode.pass_1null1257     function tguidconstnode.pass_1 : tnode;
1258       begin
1259          result:=nil;
1260          expectloc:=LOC_CREFERENCE;
1261         if (cs_create_pic in current_settings.moduleswitches) and
1262           (tf_pic_uses_got in target_info.flags) then
1263           include(current_procinfo.flags,pi_needs_got);
1264       end;
1265 
1266 
tguidconstnode.docomparenull1267     function tguidconstnode.docompare(p: tnode): boolean;
1268       begin
1269         docompare :=
1270           inherited docompare(p) and
1271           (guid2string(value) = guid2string(tguidconstnode(p).value));
1272       end;
1273 
1274 end.
1275