paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-20 09:29:26 +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

8
compiler/cg68k.pas
View File

@ -2370,6 +2370,8 @@ 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,
@ -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

45
compiler/cgi386.pas
View File

@ -1864,8 +1864,37 @@ 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
(hp^.resulttype^.deftype=orddef) then
begin
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)));
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
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;
@ -1879,7 +1908,6 @@ implementation
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),R_EDI)));
end
{ range checking for u32bit ?? !!!!!!}
else if porddef(hp^.resulttype)^.typ=u16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
@ -1924,6 +1952,7 @@ implementation
exit;
*)
end;
end;
{ p^.location.loc is already set! }
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
@ -2021,6 +2050,8 @@ 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,
@ -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

14
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,6 +2117,8 @@ 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,
@ -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

18
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;
@ -59,6 +62,12 @@ unit pbase;
{ 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

179
compiler/pdecl.pas
View File

@ -130,11 +130,13 @@ unit pdecl;
{ 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,16 +1046,37 @@ 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);
{ 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
begin
{ range type }
consume(POINTPOINT);
{ range type declaration }
do_firstpass(pt1);
pt2:=comp_expr(not(ignore_equal));
do_firstpass(pt2);
{ valid expression ? }
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
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 }
@ -1063,46 +1085,17 @@ unit pdecl;
p:=new(porddef,init(uauto,0,0));
end
else
p:=new(porddef,init(uauto,pt^.left^.value,pt^.right^.value));
disposetree(pt);
p:=new(porddef,init(uauto,pt1^.value,pt2^.value));
disposetree(pt2);
end;
disposetree(pt1);
end;
begin
case token of
ID,_STRING,_FILE:
p:=single_type(hs);
LKLAMMER:
begin
consume(LKLAMMER);
l:=-1;
aufsym := Nil;
aufdef:=new(penumdef,init);
repeat
s:=pattern;
consume(ID);
if token=ASSIGNMENT then
begin
consume(ASSIGNMENT);
v:=get_intconst;
{ please leave that a note, allows type save }
{ declarations in the win32 units ! }
if v<=l then
Message(parser_n_duplicate_enum);
l:=v;
end
else
inc(l);
constsymtable^.insert(new(penumsym,init(s,aufdef,l)));
if token=COMMA then
consume(COMMA)
else
break;
until false;
aufdef^.max:=l;
p:=aufdef;
consume(RKLAMMER);
end;
_ARRAY:
var
pt : ptree;
procedure array_dec;
begin
consume(_ARRAY);
consume(LECKKLAMMER);
@ -1183,12 +1176,12 @@ unit pdecl;
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
Message(sym_e_error_in_type_def);
{ Registrierung der Grenzen erzwingen: }
{$IfNdef GDB}
{ 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}
{$endif GDB}
if p=nil then
begin
ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
@ -1212,6 +1205,44 @@ unit pdecl;
if assigned(ap) then
ap^.definition:=hp1;
end;
begin
case token of
_STRING,_FILE:
p:=single_type(hs);
LKLAMMER:
begin
consume(LKLAMMER);
l:=-1;
aufsym := Nil;
aufdef:=new(penumdef,init);
repeat
s:=pattern;
consume(ID);
if token=ASSIGNMENT then
begin
consume(ASSIGNMENT);
v:=get_intconst;
{ please leave that a note, allows type save }
{ declarations in the win32 units ! }
if v<=l then
Message(parser_n_duplicate_enum);
l:=v;
end
else
inc(l);
constsymtable^.insert(new(penumsym,init(s,aufdef,l)));
if token=COMMA then
consume(COMMA)
else
break;
until false;
aufdef^.max:=l;
p:=aufdef;
consume(RKLAMMER);
end;
_ARRAY:
array_dec;
_SET:
begin
consume(_SET);
@ -1267,11 +1298,19 @@ unit pdecl;
_PACKED:
begin
consume(_PACKED);
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:
p:=object_dec(name,nil);
@ -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,13 +1620,19 @@ 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
_FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
unter_dec;
_EXPORTS:
if islibrary then
read_exports
else
break;
@ -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: