paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 09:06:02 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ code for initialized vars in Delphi mode

Browse Source
This commit is contained in:
pierre 1999-04-25 22:42:16 +00:00
parent 03b80377e0
commit b5dc3cc64d
3 changed files with 104 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
compiler/pdecl.pas
View File

@ -196,11 +196,21 @@ unit pdecl;
block_type:=bt_const; block_type:=bt_const;
storetokenpos:=tokenpos; storetokenpos:=tokenpos;
tokenpos:=filepos; tokenpos:=filepos;
sym:=new(ptypedconstsym,init(name,def)); {$ifdef DELPHI_CONST_IN_RODATA}
if m_delphi in aktmodeswitches then
sym:=new(ptypedconstsym,init(name,def,true))
else
{$endif DELPHI_CONST_IN_RODATA}
sym:=new(ptypedconstsym,init(name,def,false));
tokenpos:=storetokenpos; tokenpos:=storetokenpos;
symtablestack^.insert(sym); symtablestack^.insert(sym);
consume(EQUAL); consume(EQUAL);
readtypedconst(def,ptypedconstsym(sym)); {$ifdef DELPHI_CONST_IN_RODATA}
if m_delphi in aktmodeswitches then
readtypedconst(def,ptypedconstsym(sym),true)
else
{$endif DELPHI_CONST_IN_RODATA}
readtypedconst(def,ptypedconstsym(sym),false);
consume(SEMICOLON); consume(SEMICOLON);
end; end;
else consume(EQUAL); else consume(EQUAL);
@ -260,6 +270,8 @@ unit pdecl;
C_name : string; C_name : string;
{ case } { case }
p,casedef : pdef; p,casedef : pdef;
{ Delphi initialized vars }
pconstsym : ptypedconstsym;
{ maxsize contains the max. size of a variant } { maxsize contains the max. size of a variant }
{ startvarrec contains the start of the variant part of a record } { startvarrec contains the start of the variant part of a record }
maxsize,startvarrec : longint; maxsize,startvarrec : longint;
@ -290,7 +302,11 @@ unit pdecl;
consume(CSTRING); consume(CSTRING);
Is_gpc_name:=true; Is_gpc_name:=true;
end; end;
{ this is needed for Delphi mode at least
but should be OK for all modes !! (PM) }
ignore_equal:=true;
p:=read_type(''); p:=read_type('');
ignore_equal:=false;
symdone:=false; symdone:=false;
if is_gpc_name then if is_gpc_name then
begin begin
@ -378,6 +394,26 @@ unit pdecl;
Message(parser_e_absolute_only_to_var_or_const); Message(parser_e_absolute_only_to_var_or_const);
symdone:=true; symdone:=true;
end; end;
{ Handling of Delphi typed const = initialized vars ! }
{ When should this be rejected ?
- in parasymtable
- in record or object
- ... (PM) }
if (m_delphi in aktmodeswitches) and (token=EQUAL) and
not (symtablestack^.symtabletype in [parasymtable]) and
not is_record and not is_object then
begin
storetokenpos:=tokenpos;
s:=sc^.get_with_tokeninfo(tokenpos);
if not sc^.empty then
Message(parser_e_initialized_only_one_var);
pconstsym:=new(ptypedconstsym,init(s,p,false));
tokenpos:=storetokenpos;
symtablestack^.insert(pconstsym);
consume(EQUAL);
readtypedconst(p,pconstsym,false);
symdone:=true;
end;
{ for a record there doesn't need to be a ; before the END or ) } { for a record there doesn't need to be a ; before the END or ) }
if not((is_record or is_object) and (token in [_END,RKLAMMER])) then if not((is_record or is_object) and (token in [_END,RKLAMMER])) then
consume(SEMICOLON); consume(SEMICOLON);
@ -2222,7 +2258,10 @@ unit pdecl;
end. end.
{ {
$Log$ $Log$
Revision 1.109 1999-04-21 09:43:45 peter Revision 1.110 1999-04-25 22:42:16 pierre
+ code for initialized vars in Delphi mode
Revision 1.109 1999/04/21 09:43:45 peter
* storenumber works * storenumber works
* fixed some typos in double_checksum * fixed some typos in double_checksum
+ incompatible types type1 and type2 message (with storenumber) + incompatible types type1 and type2 message (with storenumber)

108
compiler/ptconst.pas
View File

@ -29,7 +29,7 @@ unit ptconst;
{ this procedure reads typed constants } { this procedure reads typed constants }
{ sym is only needed for ansi strings } { sym is only needed for ansi strings }
{ the assembler label is in the middle (PM) } { the assembler label is in the middle (PM) }
procedure readtypedconst(def : pdef;sym : ptypedconstsym); procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
implementation implementation
@ -56,7 +56,7 @@ unit ptconst;
{ this procedure reads typed constants } { this procedure reads typed constants }
procedure readtypedconst(def : pdef;sym : ptypedconstsym); procedure readtypedconst(def : pdef;sym : ptypedconstsym;no_change_allowed : boolean);
var var
{$ifdef m68k} {$ifdef m68k}
@ -66,6 +66,7 @@ unit ptconst;
p,hp : ptree; p,hp : ptree;
i,l,offset, i,l,offset,
strlength : longint; strlength : longint;
curconstsegment : paasmoutput;
ll : plabel; ll : plabel;
s : string; s : string;
ca : pchar; ca : pchar;
@ -97,6 +98,10 @@ unit ptconst;
{$R-} {Range check creates problem with init_8bit(-1) !!} {$R-} {Range check creates problem with init_8bit(-1) !!}
begin begin
if no_change_allowed then
curconstsegment:=consts
else
curconstsegment:=datasegment;
case def^.deftype of case def^.deftype of
orddef: orddef:
begin begin
@ -110,7 +115,7 @@ unit ptconst;
Message(cg_e_illegal_expression) Message(cg_e_illegal_expression)
else else
begin begin
datasegment^.concat(new(pai_const,init_8bit(p^.value))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
check_range; check_range;
end; end;
end; end;
@ -119,7 +124,7 @@ unit ptconst;
Message(cg_e_illegal_expression) Message(cg_e_illegal_expression)
else else
begin begin
datasegment^.concat(new(pai_const,init_32bit(p^.value))); curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
check_range; check_range;
end; end;
end; end;
@ -127,23 +132,23 @@ unit ptconst;
if not is_constintnode(p) then if not is_constintnode(p) then
Message(cg_e_illegal_expression) Message(cg_e_illegal_expression)
else else
datasegment^.concat(new(pai_const,init_32bit(p^.value))); curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
end; end;
bool8bit : begin bool8bit : begin
if not is_constboolnode(p) then if not is_constboolnode(p) then
Message(cg_e_illegal_expression); Message(cg_e_illegal_expression);
datasegment^.concat(new(pai_const,init_8bit(p^.value))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
end; end;
uchar : begin uchar : begin
if not is_constcharnode(p) then if not is_constcharnode(p) then
Message(cg_e_illegal_expression); Message(cg_e_illegal_expression);
datasegment^.concat(new(pai_const,init_8bit(p^.value))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value)));
end; end;
u16bit, u16bit,
s16bit : begin s16bit : begin
if not is_constintnode(p) then if not is_constintnode(p) then
Message(cg_e_illegal_expression); Message(cg_e_illegal_expression);
datasegment^.concat(new(pai_const,init_16bit(p^.value))); curconstsegment^.concat(new(pai_const,init_16bit(p^.value)));
check_range; check_range;
end; end;
s64bitint, s64bitint,
@ -154,8 +159,8 @@ unit ptconst;
else else
begin begin
{!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) } {!!!!! hmmm, we can write yet only consts til 2^32-1 :( (FK) }
datasegment^.concat(new(pai_const,init_32bit(p^.value))); curconstsegment^.concat(new(pai_const,init_32bit(p^.value)));
datasegment^.concat(new(pai_const,init_32bit(0))); curconstsegment^.concat(new(pai_const,init_32bit(0)));
end; end;
end; end;
end; end;
@ -173,11 +178,11 @@ unit ptconst;
Message(cg_e_illegal_expression); Message(cg_e_illegal_expression);
case pfloatdef(def)^.typ of case pfloatdef(def)^.typ of
s64real : datasegment^.concat(new(pai_double,init(value))); s64real : curconstsegment^.concat(new(pai_double,init(value)));
s32real : datasegment^.concat(new(pai_single,init(value))); s32real : curconstsegment^.concat(new(pai_single,init(value)));
s80real : datasegment^.concat(new(pai_extended,init(value))); s80real : curconstsegment^.concat(new(pai_extended,init(value)));
s64bit : datasegment^.concat(new(pai_comp,init(value))); s64bit : curconstsegment^.concat(new(pai_comp,init(value)));
f32bit : datasegment^.concat(new(pai_const,init_32bit(trunc(value*65536)))); f32bit : curconstsegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
else internalerror(18); else internalerror(18);
end; end;
disposetree(p); disposetree(p);
@ -204,7 +209,7 @@ unit ptconst;
end; end;
{ nil pointer ? } { nil pointer ? }
if p^.treetype=niln then if p^.treetype=niln then
datasegment^.concat(new(pai_const,init_32bit(0))) curconstsegment^.concat(new(pai_const,init_32bit(0)))
{ maybe pchar ? } { maybe pchar ? }
else else
if (ppointerdef(def)^.definition^.deftype=orddef) and if (ppointerdef(def)^.definition^.deftype=orddef) and
@ -212,7 +217,7 @@ unit ptconst;
(p^.treetype<>addrn) then (p^.treetype<>addrn) then
begin begin
getdatalabel(ll); getdatalabel(ll);
datasegment^.concat(new(pai_const_symbol,init(lab2str(ll)))); curconstsegment^.concat(new(pai_const_symbol,init(lab2str(ll))));
consts^.concat(new(pai_label,init(ll))); consts^.concat(new(pai_label,init(ll)));
if p^.treetype=stringconstn then if p^.treetype=stringconstn then
begin begin
@ -272,7 +277,9 @@ unit ptconst;
end; end;
hp:=hp^.left; hp:=hp^.left;
end; end;
datasegment^.concat(new(pai_const_symbol,init_offset(hp^.symtableentry^.mangledname,offset))); if hp^.symtableentry^.typ=constsym then
Message(type_e_variable_id_expected);
curconstsegment^.concat(new(pai_const_symbol,init_offset(hp^.symtableentry^.mangledname,offset)));
(*if token=POINT then (*if token=POINT then
begin begin
offset:=0; offset:=0;
@ -289,12 +296,12 @@ unit ptconst;
end; end;
consume(ID); consume(ID);
end; end;
datasegment^.concat(new(pai_const_symbol_offset,init( curconstsegment^.concat(new(pai_const_symbol_offset,init(
strpnew(p^.left^.symtableentry^.mangledname),offset))); strpnew(p^.left^.symtableentry^.mangledname),offset)));
end end
else else
begin begin
datasegment^.concat(new(pai_const,init_symbol( curconstsegment^.concat(new(pai_const,init_symbol(
strpnew(p^.left^.symtableentry^.mangledname)))); strpnew(p^.left^.symtableentry^.mangledname))));
end; *) end; *)
maybe_concat_external(hp^.symtableentry^.owner, maybe_concat_external(hp^.symtableentry^.owner,
@ -310,7 +317,7 @@ unit ptconst;
begin begin
if (p^.left^.treetype=typen) then if (p^.left^.treetype=typen) then
begin begin
datasegment^.concat(new(pai_const_symbol,init(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))); curconstsegment^.concat(new(pai_const_symbol,init(pobjectdef(p^.left^.resulttype)^.vmt_mangledname)));
if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR); concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
end end
@ -334,7 +341,7 @@ unit ptconst;
begin begin
{$ifdef i386} {$ifdef i386}
for l:=0 to def^.savesize-1 do for l:=0 to def^.savesize-1 do
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[l]))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
{$endif} {$endif}
{$ifdef m68k} {$ifdef m68k}
j:=0; j:=0;
@ -342,10 +349,10 @@ unit ptconst;
{ HORRIBLE HACK because of endian } { HORRIBLE HACK because of endian }
{ now use intel endian for constant sets } { now use intel endian for constant sets }
begin begin
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3]))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2]))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1]))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j]))); curconstsegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
Inc(j,4); Inc(j,4);
end; end;
{$endif} {$endif}
@ -362,7 +369,7 @@ unit ptconst;
if p^.treetype=ordconstn then if p^.treetype=ordconstn then
begin begin
if is_equal(p^.resulttype,def) then if is_equal(p^.resulttype,def) then
datasegment^.concat(new(pai_const,init_32bit(p^.value))) curconstsegment^.concat(new(pai_const,init_32bit(p^.value)))
else else
Message(cg_e_illegal_expression); Message(cg_e_illegal_expression);
end end
@ -384,16 +391,16 @@ unit ptconst;
strlength:=def^.size-1 strlength:=def^.size-1
else else
strlength:=p^.length; strlength:=p^.length;
datasegment^.concat(new(pai_const,init_8bit(strlength))); curconstsegment^.concat(new(pai_const,init_8bit(strlength)));
{ this can also handle longer strings } { this can also handle longer strings }
getmem(ca,strlength+1); getmem(ca,strlength+1);
move(p^.value_str^,ca^,strlength); move(p^.value_str^,ca^,strlength);
ca[strlength]:=#0; ca[strlength]:=#0;
datasegment^.concat(new(pai_string,init_length_pchar(ca,strlength))); curconstsegment^.concat(new(pai_string,init_length_pchar(ca,strlength)));
end end
else if is_constcharnode(p) then else if is_constcharnode(p) then
begin begin
datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value))))); curconstsegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
strlength:=1; strlength:=1;
end end
else Message(cg_e_illegal_expression); else Message(cg_e_illegal_expression);
@ -406,7 +413,7 @@ unit ptconst;
fillchar(ca[0],def^.size-strlength-1,' '); fillchar(ca[0],def^.size-strlength-1,' ');
ca[def^.size-strlength-1]:=#0; ca[def^.size-strlength-1]:=#0;
{ this can also handle longer strings } { this can also handle longer strings }
datasegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1))); curconstsegment^.concat(new(pai_string,init_length_pchar(ca,def^.size-strlength-1)));
end; end;
end; end;
{$ifdef UseLongString} {$ifdef UseLongString}
@ -417,9 +424,9 @@ unit ptconst;
else else
strlength:=p^.length; strlength:=p^.length;
{ first write the maximum size } { first write the maximum size }
datasegment^.concat(new(pai_const,init_32bit(strlength))))); curconstsegment^.concat(new(pai_const,init_32bit(strlength)))));
{ fill byte } { fill byte }
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
if p^.treetype=stringconstn then if p^.treetype=stringconstn then
begin begin
getmem(ca,strlength+1); getmem(ca,strlength+1);
@ -432,14 +439,14 @@ unit ptconst;
consts^.concat(new(pai_const,init_8bit(p^.value))); consts^.concat(new(pai_const,init_8bit(p^.value)));
end end
else Message(cg_e_illegal_expression); else Message(cg_e_illegal_expression);
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
end; end;
{$endif UseLongString} {$endif UseLongString}
st_ansistring: st_ansistring:
begin begin
{ an empty ansi string is nil! } { an empty ansi string is nil! }
if (p^.treetype=stringconstn) and (p^.length=0) then if (p^.treetype=stringconstn) and (p^.length=0) then
datasegment^.concat(new(pai_const,init_32bit(0))) curconstsegment^.concat(new(pai_const,init_32bit(0)))
else else
begin begin
if is_constcharnode(p) then if is_constcharnode(p) then
@ -447,7 +454,7 @@ unit ptconst;
else else
strlength:=p^.length; strlength:=p^.length;
getdatalabel(ll); getdatalabel(ll);
datasegment^.concat(new(pai_const_symbol,init(lab2str(ll)))); curconstsegment^.concat(new(pai_const_symbol,init(lab2str(ll))));
{ first write the maximum size } { first write the maximum size }
consts^.concat(new(pai_const,init_32bit(strlength))); consts^.concat(new(pai_const,init_32bit(strlength)));
{ second write the real length } { second write the real length }
@ -481,10 +488,10 @@ unit ptconst;
consume(LKLAMMER); consume(LKLAMMER);
for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
begin begin
readtypedconst(parraydef(def)^.definition,nil); readtypedconst(parraydef(def)^.definition,nil,no_change_allowed);
consume(COMMA); consume(COMMA);
end; end;
readtypedconst(parraydef(def)^.definition,nil); readtypedconst(parraydef(def)^.definition,nil,no_change_allowed);
consume(RKLAMMER); consume(RKLAMMER);
end end
else else
@ -524,12 +531,12 @@ unit ptconst;
begin begin
if i+1-Parraydef(def)^.lowrange<=l then if i+1-Parraydef(def)^.lowrange<=l then
begin begin
datasegment^.concat(new(pai_const,init_8bit(byte(s[1])))); curconstsegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
delete(s,1,1); delete(s,1,1);
end end
else else
{Fill the remaining positions with #0.} {Fill the remaining positions with #0.}
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
end; end;
if length(s)>0 then if length(s)>0 then
Message(parser_e_string_larger_array); Message(parser_e_string_larger_array);
@ -546,7 +553,7 @@ unit ptconst;
{ under tp: =nil or =var under fpc: =nil or =@var } { under tp: =nil or =var under fpc: =nil or =@var }
if token=_NIL then if token=_NIL then
begin begin
datasegment^.concat(new(pai_const,init_32bit(0))); curconstsegment^.concat(new(pai_const,init_32bit(0)));
consume(_NIL); consume(_NIL);
exit; exit;
end end
@ -590,7 +597,7 @@ unit ptconst;
end end
else else
Message(type_e_mismatch); Message(type_e_mismatch);
datasegment^.concat(new(pai_const_symbol,init(pd^.mangledname))); curconstsegment^.concat(new(pai_const_symbol,init(pd^.mangledname)));
if pd^.owner^.symtabletype=unitsymtable then if pd^.owner^.symtabletype=unitsymtable then
concat_external(pd^.mangledname,EXT_NEAR); concat_external(pd^.mangledname,EXT_NEAR);
end; end;
@ -620,13 +627,13 @@ unit ptconst;
{ if needed fill } { if needed fill }
if pvarsym(srsym)^.address>aktpos then if pvarsym(srsym)^.address>aktpos then
for i:=1 to pvarsym(srsym)^.address-aktpos do for i:=1 to pvarsym(srsym)^.address-aktpos do
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
{ new position } { new position }
aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size; aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
{ read the data } { read the data }
readtypedconst(pvarsym(srsym)^.definition,nil); readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
if token=SEMICOLON then if token=SEMICOLON then
consume(SEMICOLON) consume(SEMICOLON)
@ -634,7 +641,7 @@ unit ptconst;
end; end;
end; end;
for i:=1 to def^.size-aktpos do for i:=1 to def^.size-aktpos do
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
consume(RKLAMMER); consume(RKLAMMER);
end; end;
{ reads a typed object } { reads a typed object }
@ -682,13 +689,13 @@ unit ptconst;
{ if needed fill } { if needed fill }
if pvarsym(srsym)^.address>aktpos then if pvarsym(srsym)^.address>aktpos then
for i:=1 to pvarsym(srsym)^.address-aktpos do for i:=1 to pvarsym(srsym)^.address-aktpos do
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
{ new position } { new position }
aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size; aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
{ read the data } { read the data }
readtypedconst(pvarsym(srsym)^.definition,nil); readtypedconst(pvarsym(srsym)^.definition,nil,no_change_allowed);
if token=SEMICOLON then if token=SEMICOLON then
consume(SEMICOLON) consume(SEMICOLON)
@ -696,7 +703,7 @@ unit ptconst;
end; end;
end; end;
for i:=1 to def^.size-aktpos do for i:=1 to def^.size-aktpos do
datasegment^.concat(new(pai_const,init_8bit(0))); curconstsegment^.concat(new(pai_const,init_8bit(0)));
consume(RKLAMMER); consume(RKLAMMER);
end; end;
end; end;
@ -707,7 +714,10 @@ unit ptconst;
end. end.
{ {
$Log$ $Log$
Revision 1.39 1999-03-24 23:17:21 peter Revision 1.40 1999-04-25 22:42:17 pierre
+ code for initialized vars in Delphi mode
Revision 1.39 1999/03/24 23:17:21 peter
* fixed bugs 212,222,225,227,229,231,233 * fixed bugs 212,222,225,227,229,231,233
Revision 1.38 1999/02/25 21:02:45 peter Revision 1.38 1999/02/25 21:02:45 peter

4
compiler/readme
View File

@ -34,4 +34,6 @@ Changes in the syntax or semantic of FPC:
02/04/99 rtl/cfg/ directory has been removed, it's not used anymore 02/04/99 rtl/cfg/ directory has been removed, it's not used anymore
15/04/99 FINALIZATION is supported 15/04/99 FINALIZATION is supported
21/04/99 Default assembler for i386 changed to AT&T instead of direct 21/04/99 Default assembler for i386 changed to AT&T instead of direct
25/04/99: initialized vars supported in Delphi mode (only $J+ mode)
getting the address of an untyped const is now
forbidden as in BP