paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-01 04:59:32 +01:00
Code Issues Packages Projects Releases Wiki Activity

* first working array of const things

Browse Source
This commit is contained in:
peter 1998-09-23 09:58:48 +00:00
parent 232adb26c5
commit a3fbac27af
6 changed files with 453 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
compiler/cg386ld.pas
View File

@ -40,6 +40,7 @@ interface
procedure secondload(var p : ptree);
procedure secondassignment(var p : ptree);
procedure secondfuncret(var p : ptree);
procedure secondarrayconstruct(var p : ptree);
implementation
@ -559,10 +560,157 @@ implementation
end;
{*****************************************************************************
SecondArrayConstruct
*****************************************************************************}
const
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
vtWideChar = 9;
vtPWideChar = 10;
vtAnsiString = 11;
vtCurrency = 12;
vtVariant = 13;
vtInterface = 14;
vtWideString = 15;
vtInt64 = 16;
procedure emit_mov_value_ref(const t:tlocation;const ref:treference);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
t.register,newreference(ref))));
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.isintvalue then
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
t.reference.offset,newreference(ref))))
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(t.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
end;
end;
else
internalerror(330);
end;
end;
procedure emit_mov_addr_ref(const t:tlocation;const ref:treference);
begin
case t.loc of
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.isintvalue then
internalerror(331)
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(t.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
end;
end;
else
internalerror(332);
end;
end;
procedure secondarrayconstruct(var p : ptree);
var
hp : ptree;
href : treference;
hreg : tregister;
lt : pdef;
vtype : longint;
begin
clear_reference(p^.location.reference);
gettempofsizereference(parraydef(p^.resulttype)^.highrange*8,p^.location.reference);
hp:=p;
href:=p^.location.reference;
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
{ find the correct vtype value }
vtype:=$ff;
lt:=hp^.left^.resulttype;
case lt^.deftype of
enumdef,
orddef : begin
if (lt^.deftype=enumdef) or
is_integer(lt) then
vtype:=vtInteger
else
if is_boolean(lt) then
vtype:=vtBoolean
else
if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
vtype:=vtChar;
emit_mov_value_ref(hp^.left^.location,href);
end;
pointerdef : begin
if is_pchar(lt) then
vtype:=vtPChar
else
vtype:=vtPointer;
emit_mov_value_ref(hp^.left^.location,href);
end;
classrefdef : begin
vtype:=vtClass;
emit_mov_value_ref(hp^.left^.location,href);
end;
stringdef : begin
if is_shortstring(lt) then
begin
vtype:=vtString;
emit_mov_addr_ref(hp^.left^.location,href);
end
else
if is_ansistring(lt) then
begin
vtype:=vtAnsiString;
emit_mov_value_ref(hp^.left^.location,href);
end;
end;
end;
if vtype=$ff then
internalerror(14357);
{ update href to the vtype field and write it }
inc(href.offset,4);
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
vtype,newreference(href))));
{ update href to the next element }
inc(href.offset,4);
{ load next entry }
hp:=hp^.right;
end;
end;
end.
{
$Log$
Revision 1.17 1998-09-20 18:00:19 florian
Revision 1.18 1998-09-23 09:58:48 peter
* first working array of const things
Revision 1.17 1998/09/20 18:00:19 florian
* small compiling problems fixed
Revision 1.16 1998/09/20 17:46:48 florian

248
compiler/pass_1.pas
View File

@ -56,7 +56,7 @@ unit pass_1;
we don't count the ref }
const
count_ref : boolean = true;
allow_array_constructor : boolean = false;
{ marks an lvalue as "unregable" }
procedure make_not_regable(p : ptree);
@ -148,6 +148,218 @@ unit pass_1;
function is_assignment_overloaded(from_def,to_def : pdef) : boolean;forward;
procedure arrayconstructor_to_set(var p:ptree);
var
constp,
buildp,
p2,p3,p4 : ptree;
pd : pdef;
constset : pconstset;
constsetlo,
constsethi : longint;
procedure update_constsethi(p:pdef);
begin
if ((p^.deftype=orddef) and
(porddef(p)^.high>constsethi)) then
constsethi:=porddef(p)^.high
else
if ((p^.deftype=enumdef) and
(penumdef(p)^.max>constsethi)) then
constsethi:=penumdef(p)^.max;
end;
procedure do_set(pos : longint);
var
mask,l : longint;
begin
if (pos>255) or (pos<0) then
Message(parser_e_illegal_set_expr);
if pos>constsethi then
constsethi:=pos;
if pos<constsetlo then
constsetlo:=pos;
l:=pos shr 3;
mask:=1 shl (pos mod 8);
{ do we allow the same twice }
if (constset^[l] and mask)<>0 then
Message(parser_e_illegal_set_expr);
constset^[l]:=constset^[l] or mask;
end;
var
l : longint;
begin
new(constset);
FillChar(constset^,sizeof(constset^),0);
pd:=nil;
constsetlo:=0;
constsethi:=0;
constp:=gensinglenode(setconstn,nil);
constp^.value_set:=constset;
buildp:=constp;
if assigned(p^.left) then
begin
while assigned(p) do
begin
p4:=nil; { will contain the tree to create the set }
{ split a range into p2 and p3 }
if p^.left^.treetype=arrayconstructrangen then
begin
p2:=p^.left^.left;
p3:=p^.left^.right;
{ node is not used anymore }
putnode(p^.left);
end
else
begin
p2:=p^.left;
p3:=nil;
end;
firstpass(p2);
if codegenerror then
break;
case p2^.resulttype^.deftype of
enumdef,
orddef : begin
if (p2^.resulttype^.deftype=orddef) and
(porddef(p2^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then
begin
p2:=gentypeconvnode(p2,u8bitdef);
firstpass(p2);
end;
{ set settype result }
if pd=nil then
pd:=p2^.resulttype;
if not(is_equal(pd,p2^.resulttype)) then
begin
Message(type_e_typeconflict_in_set);
disposetree(p2);
end
else
begin
if assigned(p3) then
begin
if (p3^.resulttype^.deftype=orddef) and
(porddef(p3^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then
begin
p3:=gentypeconvnode(p3,u8bitdef);
firstpass(p3);
end;
if not(is_equal(pd,p3^.resulttype)) then
Message(type_e_typeconflict_in_set)
else
begin
if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then
begin
for l:=p2^.value to p3^.value do
do_set(l);
disposetree(p3);
disposetree(p2);
end
else
begin
update_constsethi(p3^.resulttype);
p4:=gennode(setelementn,p2,p3);
end;
end;
end
else
begin
{ Single value }
if p2^.treetype=ordconstn then
begin
do_set(p2^.value);
disposetree(p2);
end
else
begin
update_constsethi(p2^.resulttype);
p4:=gennode(setelementn,p2,nil);
end;
end;
end;
end;
stringdef : begin
if pd=nil then
pd:=cchardef;
if not(is_equal(pd,cchardef)) then
Message(type_e_typeconflict_in_set)
else
for l:=1 to length(pstring(p2^.value_str)^) do
do_set(ord(pstring(p2^.value_str)^[l]));
disposetree(p2);
end;
else
Internalerror(4234);
end;
{ insert the set creation tree }
if assigned(p4) then
buildp:=gennode(addn,buildp,p4);
{ load next and dispose current node }
p2:=p;
p:=p^.right;
putnode(p2);
end;
end
else
begin
{ empty set [], only remove node }
putnode(p);
end;
{ set the initial set type }
constp^.resulttype:=new(psetdef,init(pd,constsethi));
{ set the new tree }
p:=buildp;
end;
procedure firstarrayconstruct(var p : ptree);
var
pd : pdef;
hp : ptree;
len : longint;
begin
{ are we allowing array constructor? Then convert it to a set }
if not allow_array_constructor then
begin
arrayconstructor_to_set(p);
firstpass(p);
exit;
end;
{ only pass left tree, right tree contains next construct if any }
pd:=nil;
len:=0;
if assigned(p^.left) then
begin
hp:=p;
while assigned(hp) do
begin
firstpass(hp^.left);
if (pd=nil) then
pd:=hp^.left^.resulttype
else
Comment(V_Warning,'Variant type found !!');
inc(len);
hp:=hp^.right;
end;
if len=0 then
Internalerror(4235);
end;
calcregisters(p,0,0,0);
p^.resulttype:=new(parraydef,init(0,len,pd));
p^.location.loc:=LOC_REFERENCE;
end;
procedure firstarrayconstructrange(var p : ptree);
begin
{ This is not allowed, it's only to support sets when parsing the [a..b] }
Internalerror(4236);
Codegenerror:=true;
end;
function isconvertable(def_from,def_to : pdef;
var doconv : tconverttype;fromtreetype : ttreetyp;
explicit : boolean) : boolean;
@ -422,7 +634,7 @@ unit pass_1;
{ string constant to zero terminated string constant }
if (fromtreetype=stringconstn) and
((def_to^.deftype=pointerdef) and is_equal(Ppointerdef(def_to)^.definition,cchardef)) then
is_pchar(def_to) then
begin
doconv:=tc_cstring_charpointer;
b:=true;
@ -1928,6 +2140,7 @@ unit pass_1;
{ assignements to open arrays aren't allowed }
if is_open_array(p^.left^.resulttype) then
CGMessage(type_e_mismatch);
{ test if we can avoid copying string to temp
as in s:=s+...; (PM) }
{$ifdef dummyi386}
@ -2895,6 +3108,7 @@ unit pass_1;
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
var store_valid : boolean;
old_array_constructor : boolean;
convtyp : tconverttype;
begin
inc(parsing_para_level);
@ -2912,21 +3126,17 @@ unit pass_1;
end;
if defcoll=nil then
begin
{ this breaks typeconversions in write !!! (PM) }
{if not(assigned(p^.resulttype)) then }
old_array_constructor:=allow_array_constructor;
allow_array_constructor:=true;
if not(assigned(p^.resulttype)) or
(p^.left^.treetype=typeconvn) then
firstpass(p^.left);
{else
exit; this broke the
value of registers32 !! }
allow_array_constructor:=old_array_constructor;
if codegenerror then
begin
dec(parsing_para_level);
exit;
end;
p^.resulttype:=p^.left^.resulttype;
end
{ if we know the routine which is called, then the type }
@ -2948,7 +3158,12 @@ unit pass_1;
p^.left^.treetype,false) then
if convtyp=tc_array_to_pointer then
must_be_valid:=false;
firstpass(p^.left);
{ only process typeconvn, else it will break other trees }
old_array_constructor:=allow_array_constructor;
allow_array_constructor:=true;
{ if (p^.left^.treetype=typeconvn) then }
firstpass(p^.left);
allow_array_constructor:=old_array_constructor;
must_be_valid:=store_valid;
end;
if not(is_shortstring(p^.left^.resulttype) and
@ -4596,7 +4811,7 @@ unit pass_1;
firstpass(p^.right);
if codegenerror then
exit;
exit;
if p^.right^.resulttype^.deftype<>setdef then
CGMessage(sym_e_set_expected);
@ -5211,7 +5426,7 @@ unit pass_1;
pobjectdef(p^.left^.resulttype)))) then
CGMessage(type_e_mismatch);
p^.location:=p^.left^.location;
set_location(p^.location,p^.left^.location);
p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.definition;
end;
@ -5427,7 +5642,9 @@ unit pass_1;
firstgoto,firstsimplenewdispose,firsttryexcept,
firstraise,firstnothing,firsttryfinally,
firstonn,firstis,firstas,firstadd,
firstnothing,firstadd,firstprocinline,firstnothing,firstloadvmt);
firstnothing,firstadd,firstprocinline,
firstarrayconstruct,firstarrayconstructrange,
firstnothing,firstloadvmt);
var
oldcodegenerror : boolean;
@ -5516,7 +5733,10 @@ unit pass_1;
end.
{
$Log$
Revision 1.89 1998-09-22 15:34:10 peter
Revision 1.90 1998-09-23 09:58:49 peter
* first working array of const things
Revision 1.89 1998/09/22 15:34:10 peter
+ pchar -> string conversion
Revision 1.88 1998/09/21 08:45:14 pierre

7
compiler/pass_2.pas
View File

@ -196,6 +196,8 @@ implementation
secondfail, {failn}
secondadd, {starstarn}
secondprocinline, {procinlinen}
secondarrayconstruct, {arrayconstructn}
secondnothing, {arrayconstructrangen}
secondnothing, {nothingn}
secondloadvmt {loadvmtn}
);
@ -483,7 +485,10 @@ implementation
end.
{
$Log$
Revision 1.5 1998-09-21 10:01:06 peter
Revision 1.6 1998-09-23 09:58:52 peter
* first working array of const things
Revision 1.5 1998/09/21 10:01:06 peter
* check if procinfo.def is assigned before storing registersfpu
Revision 1.4 1998/09/21 08:45:16 pierre

168
compiler/pexpr.pas
View File

@ -972,146 +972,42 @@ unit pexpr;
{ Read a set between [] }
function factor_read_set:ptree;
var
constp,
buildp,
p2,p3,p4 : ptree;
pd : pdef;
constset : pconstset;
constsetlo,
constsethi : longint;
procedure update_constsethi(p:pdef);
begin
if ((p^.deftype=orddef) and
(porddef(p)^.high>constsethi)) then
constsethi:=porddef(p)^.high
else
if ((p^.deftype=enumdef) and
(penumdef(p)^.max>constsethi)) then
constsethi:=penumdef(p)^.max;
end;
procedure do_set(pos : longint);
var
mask,l : longint;
begin
if (pos>255) or (pos<0) then
Message(parser_e_illegal_set_expr);
if pos>constsethi then
constsethi:=pos;
if pos<constsetlo then
constsetlo:=pos;
l:=pos shr 3;
mask:=1 shl (pos mod 8);
{ do we allow the same twice }
if (constset^[l] and mask)<>0 then
Message(parser_e_illegal_set_expr);
constset^[l]:=constset^[l] or mask;
end;
var
l : longint;
p1,
lastp,
buildp : ptree;
begin
new(constset);
FillChar(constset^,sizeof(constset^),0);
constsetlo:=0;
constsethi:=0;
constp:=gensinglenode(setconstn,nil);
constp^.value_set:=constset;
buildp:=constp;
pd:=nil;
if token<>RECKKLAMMER then
buildp:=nil;
{ be sure that a least one arrayconstructn is used, also for an
empty [] }
if token=RECKKLAMMER then
buildp:=gennode(arrayconstructn,nil,buildp)
else
begin
while true do
begin
p4:=nil; { will contain the tree to create the set }
p2:=comp_expr(true);
do_firstpass(p2);
p1:=comp_expr(true);
do_firstpass(p1);
if codegenerror then
break;
case p2^.resulttype^.deftype of
enumdef,
orddef : begin
if (p2^.resulttype^.deftype=orddef) and
(porddef(p2^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then
begin
p2:=gentypeconvnode(p2,u8bitdef);
do_firstpass(p2);
end;
{ set settype result }
if pd=nil then
pd:=p2^.resulttype;
if not(is_equal(pd,p2^.resulttype)) then
begin
Message(type_e_typeconflict_in_set);
disposetree(p2);
end
else
begin
if token=POINTPOINT then
begin
consume(POINTPOINT);
p3:=comp_expr(true);
do_firstpass(p3);
if codegenerror then
break;
if (p3^.resulttype^.deftype=orddef) and
(porddef(p3^.resulttype)^.typ in [s8bit,s16bit,s32bit,u16bit,u32bit]) then
begin
p3:=gentypeconvnode(p3,u8bitdef);
do_firstpass(p3);
end;
if not(is_equal(pd,p3^.resulttype)) then
Message(type_e_typeconflict_in_set)
else
begin
if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then
begin
for l:=p2^.value to p3^.value do
do_set(l);
disposetree(p3);
disposetree(p2);
end
else
begin
update_constsethi(p3^.resulttype);
p4:=gennode(setelementn,p2,p3);
end;
end;
end
else
begin
{ Single value }
if p2^.treetype=ordconstn then
begin
do_set(p2^.value);
disposetree(p2);
end
else
begin
update_constsethi(p2^.resulttype);
p4:=gennode(setelementn,p2,nil);
end;
end;
end;
end;
stringdef : begin
if pd=nil then
pd:=cchardef;
if not(is_equal(pd,cchardef)) then
Message(type_e_typeconflict_in_set)
else
for l:=1 to length(pstring(p2^.value_str)^) do
do_set(ord(pstring(p2^.value_str)^[l]));
disposetree(p2);
end;
else
Internalerror(4234);
end;
{ insert the set creation tree }
if assigned(p4) then
if token=POINTPOINT then
begin
buildp:=gennode(addn,buildp,p4);
consume(POINTPOINT);
p2:=comp_expr(true);
do_firstpass(p2);
if codegenerror then
break;
p1:=gennode(arrayconstructrangen,p1,p2);
end;
{ insert at the end of the tree, to get the correct order }
if not assigned(buildp) then
begin
buildp:=gensinglenode(arrayconstructn,p1);
lastp:=buildp;
end
else
begin
lastp^.right:=gensinglenode(arrayconstructn,p1);
lastp:=lastp^.right;
end;
{ there could be more elements }
if token=COMMA then
@ -1120,7 +1016,6 @@ unit pexpr;
break;
end;
end;
constp^.resulttype:=new(psetdef,init(pd,constsethi));
factor_read_set:=buildp;
end;
@ -1856,7 +1751,10 @@ unit pexpr;
end.
{
$Log$
Revision 1.52 1998-09-20 09:38:45 florian
Revision 1.53 1998-09-23 09:58:54 peter
* first working array of const things
Revision 1.52 1998/09/20 09:38:45 florian
* hasharray for defs fixed
* ansistring code generation corrected (init/final, assignement)

9
compiler/tree.pas
View File

@ -120,7 +120,9 @@ unit tree;
caretn, {Represents the ^ operator.}
failn, {Represents the fail statement.}
starstarn, {Represents the ** operator exponentiation }
procinlinen, {Procedures that can be inlined }
procinlinen, {Procedures that can be inlined }
arrayconstructn, {Construction node for [...] parsing}
arrayconstructrangen, {Range element to allow sets in array construction tree}
{ added for optimizations where we cannot suppress }
nothingn,
loadvmtn); {???.}
@ -1567,7 +1569,10 @@ unit tree;
end.
{
$Log$
Revision 1.40 1998-09-22 15:34:07 peter
Revision 1.41 1998-09-23 09:58:55 peter
* first working array of const things
Revision 1.40 1998/09/22 15:34:07 peter
+ pchar -> string conversion
Revision 1.39 1998/09/21 08:45:27 pierre

25
compiler/types.pas
View File

@ -40,6 +40,9 @@ unit types;
{ returns true, if def defines an ordinal type }
function is_integer(def : pdef) : boolean;
{ true if p is a boolean }
function is_boolean(def : pdef) : boolean;
{ true if p points to an open array def }
function is_open_array(p : pdef) : boolean;
@ -55,6 +58,9 @@ unit types;
{ true if o is a short string def }
function is_shortstring(p : pdef) : boolean;
{ true if o is a pchar def }
function is_pchar(p : pdef) : boolean;
{ returns true, if def defines a signed data type (only for ordinal types) }
function is_signed(def : pdef) : boolean;
@ -204,6 +210,13 @@ unit types;
end;
{ true if p is a boolean }
function is_boolean(def : pdef) : boolean;
begin
is_boolean:=(def^.deftype=orddef) and
(porddef(def)^.typ in [bool8bit,bool16bit,bool32bit]);
end;
{ true if p is signed (integer) }
function is_signed(def : pdef) : boolean;
var
@ -261,6 +274,13 @@ unit types;
(pstringdef(p)^.string_typ=st_shortstring);
end;
{ true if p is a pchar def }
function is_pchar(p : pdef) : boolean;
begin
is_pchar:=(p^.deftype=pointerdef) and
is_equal(Ppointerdef(p)^.definition,cchardef);
end;
{ true if the return value is in accumulator (EAX for i386), D0 for 68k }
function ret_in_acc(def : pdef) : boolean;
@ -922,7 +942,10 @@ unit types;
end.
{
$Log$
Revision 1.30 1998-09-22 15:40:58 peter
Revision 1.31 1998-09-23 09:58:56 peter
* first working array of const things
Revision 1.30 1998/09/22 15:40:58 peter
* some extra ifdef GDB
Revision 1.29 1998/09/16 12:37:31 michael