{ $Id$ Copyright (c) 1998-2002 by Florian Klaempfl Generate assembler for constant nodes which are the same for all (most) processors This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit ncgcon; {$i fpcdefs.inc} interface uses node,ncon; type tcgrealconstnode = class(trealconstnode) procedure pass_2;override; end; tcgordconstnode = class(tordconstnode) procedure pass_2;override; end; tcgpointerconstnode = class(tpointerconstnode) procedure pass_2;override; end; tcgstringconstnode = class(tstringconstnode) procedure pass_2;override; end; tcgsetconstnode = class(tsetconstnode) procedure pass_2;override; end; tcgnilnode = class(tnilnode) procedure pass_2;override; end; tcgguidconstnode = class(tguidconstnode) procedure pass_2;override; end; implementation uses globtype,widestr,systems, verbose,globals, symconst,symdef,aasmbase,aasmtai,defbase, cpuinfo,cpubase, cginfo,cgbase,tgobj,rgobj; {***************************************************************************** TCGREALCONSTNODE *****************************************************************************} procedure tcgrealconstnode.pass_2; { I suppose the parser/pass_1 must make sure the generated real } { constants are actually supported by the target processor? (JM) } const floattype2ait:array[tfloattype] of tait= (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_comp_64bit); var hp1 : tai; lastlabel : tasmlabel; realait : tait; begin location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def)); lastlabel:=nil; realait:=floattype2ait[tfloatdef(resulttype.def).typ]; { const already used ? } if not assigned(lab_real) then begin { tries to find an old entry } hp1:=tai(Consts.first); while assigned(hp1) do begin if hp1.typ=ait_label then lastlabel:=tai_label(hp1).l else begin if (hp1.typ=realait) and (lastlabel<>nil) then begin if( ((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real)) or ((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real)) or ((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real)) or ((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real)) ) then begin { found! } lab_real:=lastlabel; break; end; end; lastlabel:=nil; end; hp1:=tai(hp1.next); end; { :-(, we must generate a new entry } if not assigned(lab_real) then begin getdatalabel(lastlabel); lab_real:=lastlabel; if (cs_create_smart in aktmoduleswitches) then Consts.concat(Tai_cut.Create); Consts.concat(Tai_label.Create(lastlabel)); case realait of ait_real_32bit : Consts.concat(Tai_real_32bit.Create(value_real)); ait_real_64bit : Consts.concat(Tai_real_64bit.Create(value_real)); ait_real_80bit : Consts.concat(Tai_real_80bit.Create(value_real)); ait_comp_64bit : Consts.concat(Tai_comp_64bit.Create(value_real)); else internalerror(10120); end; end; end; location.reference.symbol:=lab_real; end; {***************************************************************************** TCGORDCONSTNODE *****************************************************************************} procedure tcgordconstnode.pass_2; begin location_reset(location,LOC_CONSTANT,def_cgsize(resulttype.def)); location.valuelow:=AWord(value); location.valuehigh:=AWord(value shr 32); end; {***************************************************************************** TCGPOINTERCONSTNODE *****************************************************************************} procedure tcgpointerconstnode.pass_2; begin { an integer const. behaves as a memory reference } location_reset(location,LOC_CONSTANT,OS_ADDR); location.value:=AWord(value); end; {***************************************************************************** TCGSTRINGCONSTNODE *****************************************************************************} procedure tcgstringconstnode.pass_2; var hp1,hp2 : tai; l1,l2, lastlabel : tasmlabel; lastlabelhp : tai; pc : pchar; same_string : boolean; l,j, i,mylength : longint; begin { for empty ansistrings we could return a constant 0 } if (st_type in [st_ansistring,st_widestring]) and (len=0) then begin location_reset(location,LOC_CONSTANT,OS_ADDR); location.value:=0; exit; end; { return a constant reference in memory } location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def)); { const already used ? } lastlabel:=nil; lastlabelhp:=nil; if not assigned(lab_str) then begin if is_shortstring(resulttype.def) then mylength:=len+2 else mylength:=len+1; { widestrings can't be reused yet } if not(is_widestring(resulttype.def)) then begin { tries to found an old entry } hp1:=tai(Consts.first); while assigned(hp1) do begin if hp1.typ=ait_label then begin lastlabel:=tai_label(hp1).l; lastlabelhp:=hp1; end else begin { when changing that code, be careful that } { you don't use typed consts, which are } { are also written to consts } { currently, this is no problem, because } { typed consts have no leading length or } { they have no trailing zero } if (hp1.typ=ait_string) and (lastlabel<>nil) and (tai_string(hp1).len=mylength) then begin same_string:=true; { if shortstring then check the length byte first and set the start index to 1 } case st_type of st_shortstring: begin if len=ord(tai_string(hp1).str[0]) then j:=1 else same_string:=false; end; st_ansistring, st_widestring : begin { before the string the following sequence must be found: