paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 20:27:56 +02:00
Code Issues Packages Projects Releases Wiki Activity

* bug0092, bug0115 and bug0121 fixed

Browse Source 
+ packed object/class/array
This commit is contained in:
florian 1998-04-07 22:45:03 +00:00
parent e18075dc19
commit bc2d9f0a3f
9 changed files with 384 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/cg68k.pas
View File

@ -2370,12 +2370,14 @@ implementation
second_only_rangecheck,second_bigger,
second_bigger,second_bigger,
second_bigger,second_only_rangecheck,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,second_bool_to_byte,
second_proc_to_procvar,
{ is constant char to pchar, is done by firstpass }
second_nothing);
second_chararray_to_string,second_bool_to_byte,
second_proc_to_procvar,
{ is constant char to pchar, is done by firstpass }
second_nothing);
begin
{ this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
@ -5096,7 +5098,11 @@ end.
{
$Log$
Revision 1.2 1998-03-28 23:09:54 florian
Revision 1.3 1998-04-07 22:45:03 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.2 1998/03/28 23:09:54 florian
* secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit

145
compiler/cgi386.pas
View File

@ -1864,65 +1864,94 @@ implementation
{ with $R+ explicit type conversations in TP aren't range checked! }
(not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
(p^.resulttype^.deftype=orddef) and
(hp^.resulttype^.deftype=orddef) and
((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or
(porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
(hp^.resulttype^.deftype=orddef) then
begin
porddef(p^.resulttype)^.genrangecheck;
{ per default the var is copied to EDI }
hregister:=R_EDI;
if porddef(hp^.resulttype)^.typ=s32bit then
if porddef(hp^.resulttype)^.typ=u32bit then
begin
{ when doing range checking for u32bit, we have some trouble }
{ because BOUND assumes signed values }
{ first, we check if the values is greater than 2^31: }
{ the u32bit rangenr contains the appropriate rangenr }
porddef(hp^.resulttype)^.genrangecheck;
hregister:=R_EDI;
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
hregister:=p^.location.register
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.location.reference),R_EDI)));
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(hp^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp)));
{ then we do a normal range check }
porddef(p^.resulttype)^.genrangecheck;
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp)));
end
{ range checking for u32bit ?? !!!!!!}
else if porddef(hp^.resulttype)^.typ=u16bit then
else
if ((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or
(porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
begin
porddef(p^.resulttype)^.genrangecheck;
{ per default the var is copied to EDI }
hregister:=R_EDI;
if porddef(hp^.resulttype)^.typ=s32bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
hregister:=p^.location.register
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),R_EDI)));
end
else if porddef(hp^.resulttype)^.typ=u16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.location.register,R_EDI)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.location.reference),R_EDI)));
end
else if porddef(hp^.resulttype)^.typ=s16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.location.register,R_EDI)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.location.reference),R_EDI)));
end
else internalerror(6);
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp)));
(*
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.location.register,R_EDI)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.location.reference),R_EDI)));
end
else if porddef(hp^.resulttype)^.typ=s16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.location.register,R_EDI)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.location.reference),R_EDI)));
end
else internalerror(6);
new(hpp);
reset_reference(hpp^);
hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp)));
(*
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
begin
destregister:=p^.left^.location.register;
case convtyp of
tc_s32bit_2_s8bit,
tc_s32bit_2_u8bit:
destregister:=reg32toreg8(destregister);
tc_s32bit_2_s16bit,
tc_s32bit_2_u16bit:
destregister:=reg32toreg16(destregister);
{ this was false because destregister is allways a 32bitreg }
tc_s16bit_2_s8bit,
tc_s16bit_2_u8bit,
tc_u16bit_2_s8bit,
tc_u16bit_2_u8bit:
destregister:=reg32toreg8(destregister);
end;
p^.location.register:=destregister;
exit;
*)
begin
destregister:=p^.left^.location.register;
case convtyp of
tc_s32bit_2_s8bit,
tc_s32bit_2_u8bit:
destregister:=reg32toreg8(destregister);
tc_s32bit_2_s16bit,
tc_s32bit_2_u16bit:
destregister:=reg32toreg16(destregister);
{ this was false because destregister is allways a 32bitreg }
tc_s16bit_2_s8bit,
tc_s16bit_2_u8bit,
tc_u16bit_2_s8bit,
tc_u16bit_2_u8bit:
destregister:=reg32toreg8(destregister);
end;
p^.location.register:=destregister;
exit;
*)
end;
end;
{ p^.location.loc is already set! }
if (p^.location.loc=LOC_REGISTER) or
@ -2021,12 +2050,14 @@ implementation
second_only_rangecheck,second_bigger,
second_bigger,second_bigger,
second_bigger,second_only_rangecheck,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,second_bool_to_byte,
second_proc_to_procvar,
{ is constant char to pchar, is done by firstpass }
second_nothing);
second_chararray_to_string,second_bool_to_byte,
second_proc_to_procvar,
{ is constant char to pchar, is done by firstpass }
second_nothing);
begin
{ this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
@ -2039,7 +2070,7 @@ implementation
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
end;
if p^.convtyp<>tc_equal then
if (p^.convtyp<>tc_equal) and (p^.convtyp<>tc_not_possible) then
{the second argument only is for maybe_range_checking !}
secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
end;
@ -5675,7 +5706,11 @@ do_jmp:
end.
{
$Log$
Revision 1.4 1998-04-07 13:19:42 pierre
Revision 1.5 1998-04-07 22:45:04 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.4 1998/04/07 13:19:42 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation

15
compiler/parser.pas
View File

@ -94,7 +94,8 @@ unit parser;
{ ^M means a string or a char, because we don't parse a }
{ type declaration }
parse_types:=false;
block_type:=bt_general;
ignore_equal:=false;
{ we didn't parse a object or class declaration }
{ and no function header }
@ -130,7 +131,7 @@ unit parser;
oldpreprocstack : ppreprocstack;
oldorgpattern,oldprocprefix : string;
oldparse_types : boolean;
old_block_type : tblock_type;
oldinputbuffer : pchar;
oldinputpointer : longint;
olds_point,oldparse_only : boolean;
@ -247,7 +248,7 @@ unit parser;
oldpattern:=pattern;
oldtoken:=token;
oldorgpattern:=orgpattern;
oldparse_types:=parse_types;
old_block_type:=block_type;
oldpreprocstack:=preprocstack;
oldinputbuffer:=inputbuffer;
@ -477,7 +478,7 @@ done:
pattern:=oldpattern;
token:=oldtoken;
orgpattern:=oldorgpattern;
parse_types:=oldparse_types;
block_type:=old_block_type;
{ call donescanner before restoring preprocstack, because }
{ donescanner tests for a empty preprocstack }
@ -530,7 +531,11 @@ done:
end.
{
$Log$
Revision 1.2 1998-03-26 11:18:30 florian
Revision 1.3 1998-04-07 22:45:04 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.2 1998/03/26 11:18:30 florian
- switch -Sa removed
- support of a:=b:=0 removed

16
compiler/pass_1.pas
View File

@ -168,9 +168,9 @@ unit pass_1;
tc_only_rangechecks32bit,{tc_not_possible}tc_u16bit_2_u32bit),
{u32bit}
(tc_not_possible,{tc_not_possible}tc_u32bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
tc_not_possible,tc_only_rangechecks32bit)
(tc_u32bit_2_u8bit,{tc_not_possible}tc_u32bit_2_s32bit,tc_not_possible,
tc_not_possible,tc_not_possible,tc_u32bit_2_s8bit,tc_u32bit_2_s16bit,
tc_u32bit_2_u16bit,tc_only_rangechecks32bit)
);
var
@ -2117,10 +2117,12 @@ unit pass_1;
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_int_real,first_real_fix,
first_fix_real,first_int_fix,first_real_real,
first_locmem,first_bool_byte,first_proc_to_procvar,
first_cchar_charpointer);
first_cchar_charpointer);
begin
aprocdef:=nil;
@ -4492,7 +4494,11 @@ unit pass_1;
end.
{
$Log$
Revision 1.3 1998-03-28 23:09:56 florian
Revision 1.4 1998-04-07 22:45:04 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.3 1998/03/28 23:09:56 florian
* secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit

20
compiler/pbase.pas
View File

@ -39,6 +39,9 @@ unit pbase;
getprocvar : boolean = false;
getprocvardef : pprocvardef = nil;
type
tblock_type = (bt_general,bt_type,bt_const);
var
{ contains the current token to be processes }
token : ttoken;
@ -54,11 +57,17 @@ unit pbase;
refsymtable : psymtable;
{ true, if only routine headers should be }
{ parsed }
{ parsed }
parse_only : boolean;
{ true, if we are in a except block }
in_except_block : boolean;
{ type of currently parsed block }
{ isn't full implemented (FK) }
block_type : tblock_type;
{ true, if we should ignore an equal in const x : 1..2=2 }
ignore_equal : boolean;
{ consumes token i, if the current token is unequal i }
{ a syntax error is written }
@ -77,7 +86,6 @@ unit pbase;
{ sc is disposed }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
implementation
@ -197,8 +205,12 @@ end.
{
$Log$
Revision 1.1 1998-03-25 11:18:14 root
Initial revision
Revision 1.2 1998-04-07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.1.1.1 1998/03/25 11:18:14 root
* Restored version
Revision 1.9 1998/03/10 01:17:23 peter
* all files have the same header

353
compiler/pdecl.pas
View File

@ -90,7 +90,7 @@ unit pdecl;
consume(ID);
case token of
EQUAL:
begin
begin
consume(EQUAL);
p:=expr;
do_firstpass(p);
@ -126,15 +126,17 @@ unit pdecl;
consume(SEMICOLON);
end;
COLON:
begin
begin
{ this was missed, so const s : ^string = nil gives an
error (FK)
}
parse_types:=true;
block_type:=bt_type;
consume(COLON);
ignore_equal:=true;
def:=read_type('');
block_type:=bt_type;
ignore_equal:=false;
symtablestack^.insert(new(ptypedconstsym,init(name,def)));
parse_types:=false;
consume(EQUAL);
readtypedconst(def);
consume(SEMICOLON);
@ -1037,7 +1039,6 @@ unit pdecl;
var
hp1,p : pdef;
pt : ptree;
aufdef : penumdef;
aufsym : penumsym;
ap : parraydef;
@ -1045,31 +1046,169 @@ unit pdecl;
l,v,oldaktpackrecords : longint;
hs : string;
procedure range_type;
procedure expr_type;
var
pt1,pt2 : ptree;
begin
{ it can be only a range type }
pt:=expr;
do_firstpass(pt);
{ valid expression ? }
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
Begin
Message(sym_e_error_in_type_def);
{ Here we create a node type with a range of 0 }
{ To make sure that no crashes will occur later }
{ on in the compiler. }
p:=new(porddef,init(uauto,0,0));
{ use of current parsed object ? }
if (token=ID) and (testcurobject=2) and (curobjectname=pattern) then
begin
consume(ID);
p:=aktobjectdef;
exit;
end;
{ we can't accept a equal in type }
pt1:=comp_expr(not(ignore_equal));
if (pt1^.treetype=typen) and (token<>POINTPOINT) then
begin
{ a simple type renaming }
p:=pt1^.resulttype;
end
else
p:=new(porddef,init(uauto,pt^.left^.value,pt^.right^.value));
disposetree(pt);
begin
{ range type }
consume(POINTPOINT);
{ range type declaration }
do_firstpass(pt1);
pt2:=comp_expr(not(ignore_equal));
do_firstpass(pt2);
{ valid expression ? }
if (pt1^.treetype<>ordconstn) or
(pt2^.treetype<>ordconstn) then
Begin
Message(sym_e_error_in_type_def);
{ Here we create a node type with a range of 0 }
{ To make sure that no crashes will occur later }
{ on in the compiler. }
p:=new(porddef,init(uauto,0,0));
end
else
p:=new(porddef,init(uauto,pt1^.value,pt2^.value));
disposetree(pt2);
end;
disposetree(pt1);
end;
var
pt : ptree;
procedure array_dec;
begin
consume(_ARRAY);
consume(LECKKLAMMER);
p:=nil;
repeat
{ read the expression and check it }
pt:=expr;
if pt^.treetype=typen then
begin
if pt^.resulttype^.deftype=enumdef then
begin
if p=nil then
begin
ap:=new(parraydef,
init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,
init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end
else if pt^.resulttype^.deftype=orddef then
begin
case porddef(pt^.resulttype)^.typ of
s8bit,u8bit,s16bit,u16bit,s32bit :
begin
if p=nil then
begin
ap:=new(parraydef,init(porddef(pt^.resulttype)^.von,
porddef(pt^.resulttype)^.bis,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(porddef(pt^.resulttype)^.von,
porddef(pt^.resulttype)^.bis,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
bool8bit:
begin
if p=nil then
begin
ap:=new(parraydef,init(0,1,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(0,1,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
uchar:
begin
if p=nil then
begin
ap:=new(parraydef,init(0,255,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(0,255,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
else Message(sym_e_error_in_type_def);
end;
end
else Message(sym_e_error_in_type_def);
end
else
begin
do_firstpass(pt);
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
Message(sym_e_error_in_type_def);
{ force the registration of the ranges }
{$ifndef GDB}
if pt^.right^.resulttype=pdef(s32bitdef) then
pt^.right^.resulttype:=new(porddef,init(
s32bit,$80000000,$7fffffff));
{$endif GDB}
if p=nil then
begin
ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
disposetree(pt);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
consume(_OF);
hp1:=read_type('');
{ if no error, set element type }
if assigned(ap) then
ap^.definition:=hp1;
end;
begin
case token of
ID,_STRING,_FILE:
_STRING,_FILE:
p:=single_type(hs);
LKLAMMER:
begin
@ -1103,115 +1242,7 @@ unit pdecl;
consume(RKLAMMER);
end;
_ARRAY:
begin
consume(_ARRAY);
consume(LECKKLAMMER);
p:=nil;
repeat
{ read the expression and check it }
pt:=expr;
if pt^.treetype=typen then
begin
if pt^.resulttype^.deftype=enumdef then
begin
if p=nil then
begin
ap:=new(parraydef,
init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,
init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end
else if pt^.resulttype^.deftype=orddef then
begin
case porddef(pt^.resulttype)^.typ of
s8bit,u8bit,s16bit,u16bit,s32bit :
begin
if p=nil then
begin
ap:=new(parraydef,init(porddef(pt^.resulttype)^.von,
porddef(pt^.resulttype)^.bis,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(porddef(pt^.resulttype)^.von,
porddef(pt^.resulttype)^.bis,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
bool8bit:
begin
if p=nil then
begin
ap:=new(parraydef,init(0,1,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(0,1,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
uchar:
begin
if p=nil then
begin
ap:=new(parraydef,init(0,255,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(0,255,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
else Message(sym_e_error_in_type_def);
end;
end
else Message(sym_e_error_in_type_def);
end
else
begin
do_firstpass(pt);
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
Message(sym_e_error_in_type_def);
{ Registrierung der Grenzen erzwingen: }
{$IfNdef GDB}
if pt^.right^.resulttype=pdef(s32bitdef) then
pt^.right^.resulttype:=new(porddef,init(
s32bit,$80000000,$7fffffff));
{$EndIf GDB}
if p=nil then
begin
ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
disposetree(pt);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
consume(_OF);
hp1:=read_type('');
{ if no error, set element type }
if assigned(ap) then
ap^.definition:=hp1;
end;
array_dec;
_SET:
begin
consume(_SET);
@ -1267,10 +1298,18 @@ unit pdecl;
_PACKED:
begin
consume(_PACKED);
oldaktpackrecords:=aktpackrecords;
aktpackrecords:=1;
p:=record_dec;
aktpackrecords:=oldaktpackrecords;
if token=_ARRAY then
array_dec
else
begin
oldaktpackrecords:=aktpackrecords;
aktpackrecords:=1;
if token in [_CLASS,_OBJECT] then
p:=object_dec(name,nil)
else
p:=record_dec;
aktpackrecords:=oldaktpackrecords;
end;
end;
_CLASS,
_OBJECT:
@ -1288,7 +1327,7 @@ unit pdecl;
pprocvardef(p)^.retdef:=single_type(hs);
end;
else
range_type;
expr_type;
end;
read_type:=p;
end;
@ -1312,7 +1351,7 @@ unit pdecl;
{$endif dummy}
begin
parse_types:=true;
block_type:=bt_type;
consume(_TYPE);
typecanbeforward:=true;
repeat
@ -1363,7 +1402,7 @@ unit pdecl;
symtablestack^.foreach(@testforward_types);
{$endif}
resolve_forwards;
parse_types:=false;
block_type:=bt_general;
end;
{ parses varaible declarations and inserts them in }
@ -1400,14 +1439,14 @@ unit pdecl;
{ startvarrec contains the start of the variant part of a record }
maxsize,startvarrec : longint;
pt : ptree;
old_parse_types : boolean;
old_block_type : tblock_type;
{ to handle absolute }
abssym : pabsolutesym;
begin
hs:='';
old_parse_types:=parse_types;
parse_types:=true;
old_block_type:=block_type;
block_type:=bt_type;
while (token=ID) and
(pattern<>'PUBLIC') and
(pattern<>'PRIVATE') and
@ -1573,7 +1612,7 @@ unit pdecl;
{ at last set the record size to that of the biggest variant }
symtablestack^.datasize:=maxsize;
end;
parse_types:=old_parse_types;
block_type:=old_block_type;
end;
procedure read_declarations(islibrary : boolean);
@ -1581,16 +1620,22 @@ unit pdecl;
begin
repeat
case token of
_LABEL : label_dec;
_CONST : const_dec;
_TYPE : type_dec;
_VAR : var_dec;
_LABEL:
label_dec;
_CONST:
const_dec;
_TYPE:
type_dec;
_VAR:
var_dec;
_CONSTRUCTOR,_DESTRUCTOR,
_FUNCTION,_PROCEDURE,_OPERATOR,_CLASS : unter_dec;
_EXPORTS : if islibrary then
read_exports
else
break;
_FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
unter_dec;
_EXPORTS:
if islibrary then
read_exports
else
break;
else break;
end;
until false;
@ -1621,7 +1666,11 @@ unit pdecl;
end.
{
$Log$
Revision 1.2 1998-04-05 13:58:35 peter
Revision 1.3 1998-04-07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.2 1998/04/05 13:58:35 peter
* fixed the -Ss bug
+ warning for Virtual constructors
* helppages updated with -TGO32V1

40
compiler/pexpr.pas
View File

@ -29,6 +29,9 @@ unit pexpr;
{ reads a whole expression }
function expr : ptree;
{ reads an expression without assignements and .. }
function comp_expr(accept_equal : boolean):Ptree;
{ reads a single factor }
function factor(getaddr : boolean) : ptree;
@ -1408,7 +1411,7 @@ unit pexpr;
[PLUS,MINUS,_OR,_XOR],
[CARET,SYMDIF,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
function sub_expr(pred_level:Toperator_precedence):Ptree;
function sub_expr(pred_level:Toperator_precedence;accept_equal : boolean):Ptree;
{Reads a subexpression while the operators are of the current precedence
level, or any higher level. Replaces the old term, simpl_expr and
@ -1422,9 +1425,12 @@ unit pexpr;
if pred_level=opmultiply then
p1:=factor(getprocvar)
else
p1:=sub_expr(succ(pred_level));
p1:=sub_expr(succ(pred_level),true);
repeat
if token in operator_levels[pred_level] then
{ aweful hack to support const a : 1..2=1; }
{ disadvantage of tables :) FK }
if (token in operator_levels[pred_level]) and
((token<>EQUAL) or accept_equal) then
begin
oldt:=token;
consume(token);
@ -1432,7 +1438,7 @@ unit pexpr;
if pred_level=opmultiply then
p2:=factor(getprocvar)
else
p2:=sub_expr(succ(pred_level));
p2:=sub_expr(succ(pred_level),true);
p1:=gennode(tok2node[oldt],p1,p2);
end
else
@ -1441,6 +1447,12 @@ unit pexpr;
sub_expr:=p1;
end;
function comp_expr(accept_equal : boolean):Ptree;
begin
comp_expr:=sub_expr(opcompare,accept_equal);
end;
function expr : ptree;
var
@ -1449,13 +1461,13 @@ unit pexpr;
begin
oldafterassignment:=afterassignment;
p1:=sub_expr(opcompare);
p1:=sub_expr(opcompare,true);
if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true;
case token of
POINTPOINT : begin
consume(POINTPOINT);
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
p1:=gennode(rangen,p1,p2);
end;
ASSIGNMENT : begin
@ -1465,7 +1477,7 @@ unit pexpr;
{ should be recursive for a:=b:=c !!! }
if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
getprocvar:=true;
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
if getprocvar and (p2^.treetype=calln) then
begin
p2^.treetype:=loadn;
@ -1479,7 +1491,7 @@ unit pexpr;
{ from an improvement of Peter Schaefer }
_PLUSASN : begin
consume(_PLUSASN );
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
{ was first
p1:=gennode(assignn,p1,gennode(addn,p1,p2));
@ -1489,17 +1501,17 @@ unit pexpr;
_MINUSASN : begin
consume(_MINUSASN );
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
end;
_STARASN : begin
consume(_STARASN );
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
end;
_SLASHASN : begin
consume(_SLASHASN );
p2:=sub_expr(opcompare);
p2:=sub_expr(opcompare,true);
p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
end;
end;
@ -1553,7 +1565,11 @@ unit pexpr;
end.
{
$Log$
Revision 1.3 1998-04-07 13:19:46 pierre
Revision 1.4 1998-04-07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.3 1998/04/07 13:19:46 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation

13
compiler/scanner.pas
View File

@ -150,8 +150,6 @@ unit scanner;
var
pattern,orgpattern : string;
{ true, if type declarations are parsed }
parse_types : boolean;
{ macros }
@ -180,6 +178,9 @@ for the last instruction of an include file !}
implementation
uses
pbase;
const
newline = #10;
@ -1860,7 +1861,7 @@ for the last instruction of an include file !}
begin
nextchar;
c:=upcase(c);
if not(parse_types) and (c in ['A'..'Z']) then
if not(block_type=bt_type) and (c in ['A'..'Z']) then
begin
pattern:=chr(ord(c)-64);
nextchar;
@ -2102,7 +2103,11 @@ for the last instruction of an include file !}
end.
{
$Log$
Revision 1.4 1998-04-07 13:19:49 pierre
Revision 1.5 1998-04-07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.4 1998/04/07 13:19:49 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation

10
compiler/tree.pas
View File

@ -138,6 +138,8 @@ unit tree;
tc_s32bit_2_u32bit,tc_s16bit_2_u32bit,
tc_s8bit_2_u32bit,tc_u16bit_2_u32bit,
tc_u8bit_2_u32bit,tc_u32bit_2_s32bit,
tc_u32bit_2_s8bit,tc_u32bit_2_u8bit,
tc_u32bit_2_s16bit,tc_u32bit_2_u16bit,
tc_int_2_real,tc_real_2_fix,
tc_fix_2_real,tc_int_2_fix,tc_real_2_real,
tc_chararray_2_string,tc_bool_2_u8bit,
@ -1158,8 +1160,12 @@ $endif SUPPORT_MMX
end.
{
$Log$
Revision 1.1 1998-03-25 11:18:13 root
Initial revision
Revision 1.2 1998-04-07 22:45:05 florian
* bug0092, bug0115 and bug0121 fixed
+ packed object/class/array
Revision 1.1.1.1 1998/03/25 11:18:13 root
* Restored version
Revision 1.15 1998/03/24 21:48:36 florian
* just a couple of fixes applied: