paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-22 17:33:32 +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_only_rangecheck,second_bigger,
second_bigger,second_bigger, second_bigger,second_bigger,
second_bigger,second_only_rangecheck, second_bigger,second_only_rangecheck,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_int_real,second_real_fix, second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float, second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,second_bool_to_byte, second_chararray_to_string,second_bool_to_byte,
@ -5096,7 +5098,11 @@ end.
{ {
$Log$ $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) * secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in * overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit 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! } { with $R+ explicit type conversations in TP aren't range checked! }
(not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
(p^.resulttype^.deftype=orddef) and (p^.resulttype^.deftype=orddef) and
(hp^.resulttype^.deftype=orddef) and (hp^.resulttype^.deftype=orddef) then
((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or 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 (porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
begin begin
porddef(p^.resulttype)^.genrangecheck; porddef(p^.resulttype)^.genrangecheck;
@ -1879,7 +1908,6 @@ implementation
else 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)));
end end
{ range checking for u32bit ?? !!!!!!}
else if porddef(hp^.resulttype)^.typ=u16bit then else if porddef(hp^.resulttype)^.typ=u16bit then
begin begin
if (p^.location.loc=LOC_REGISTER) or if (p^.location.loc=LOC_REGISTER) or
@ -1924,6 +1952,7 @@ implementation
exit; exit;
*) *)
end; end;
end;
{ p^.location.loc is already set! } { p^.location.loc is already set! }
if (p^.location.loc=LOC_REGISTER) or if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then (p^.location.loc=LOC_CREGISTER) then
@ -2021,6 +2050,8 @@ implementation
second_only_rangecheck,second_bigger, second_only_rangecheck,second_bigger,
second_bigger,second_bigger, second_bigger,second_bigger,
second_bigger,second_only_rangecheck, second_bigger,second_only_rangecheck,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_int_real,second_real_fix, second_int_real,second_real_fix,
second_fix_real,second_int_fix,second_float_float, second_fix_real,second_int_fix,second_float_float,
second_chararray_to_string,second_bool_to_byte, second_chararray_to_string,second_bool_to_byte,
@ -2039,7 +2070,7 @@ implementation
secondpass(p^.left); secondpass(p^.left);
set_location(p^.location,p^.left^.location); set_location(p^.location,p^.left^.location);
end; 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 !} {the second argument only is for maybe_range_checking !}
secondconvert[p^.convtyp](p,p^.left,p^.convtyp) secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
end; end;
@ -5675,7 +5706,11 @@ do_jmp:
end. end.
{ {
$Log$ $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 * bugfixes for reset_gdb_info
in MEM parsing for go32v2 in MEM parsing for go32v2
better external symbol creation 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 } { ^M means a string or a char, because we don't parse a }
{ type declaration } { type declaration }
parse_types:=false; block_type:=bt_general;
ignore_equal:=false;
{ we didn't parse a object or class declaration } { we didn't parse a object or class declaration }
{ and no function header } { and no function header }
@ -130,7 +131,7 @@ unit parser;
oldpreprocstack : ppreprocstack; oldpreprocstack : ppreprocstack;
oldorgpattern,oldprocprefix : string; oldorgpattern,oldprocprefix : string;
oldparse_types : boolean; old_block_type : tblock_type;
oldinputbuffer : pchar; oldinputbuffer : pchar;
oldinputpointer : longint; oldinputpointer : longint;
olds_point,oldparse_only : boolean; olds_point,oldparse_only : boolean;
@ -247,7 +248,7 @@ unit parser;
oldpattern:=pattern; oldpattern:=pattern;
oldtoken:=token; oldtoken:=token;
oldorgpattern:=orgpattern; oldorgpattern:=orgpattern;
oldparse_types:=parse_types; old_block_type:=block_type;
oldpreprocstack:=preprocstack; oldpreprocstack:=preprocstack;
oldinputbuffer:=inputbuffer; oldinputbuffer:=inputbuffer;
@ -477,7 +478,7 @@ done:
pattern:=oldpattern; pattern:=oldpattern;
token:=oldtoken; token:=oldtoken;
orgpattern:=oldorgpattern; orgpattern:=oldorgpattern;
parse_types:=oldparse_types; block_type:=old_block_type;
{ call donescanner before restoring preprocstack, because } { call donescanner before restoring preprocstack, because }
{ donescanner tests for a empty preprocstack } { donescanner tests for a empty preprocstack }
@ -530,7 +531,11 @@ done:
end. end.
{ {
$Log$ $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 - switch -Sa removed
- support of a:=b:=0 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), tc_only_rangechecks32bit,{tc_not_possible}tc_u16bit_2_u32bit),
{u32bit} {u32bit}
(tc_not_possible,{tc_not_possible}tc_u32bit_2_s32bit,tc_not_possible, (tc_u32bit_2_u8bit,{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_not_possible,tc_u32bit_2_s8bit,tc_u32bit_2_s16bit,
tc_not_possible,tc_only_rangechecks32bit) tc_u32bit_2_u16bit,tc_only_rangechecks32bit)
); );
var 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_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_bigger_smaller,first_bigger_smaller,
first_int_real,first_real_fix, first_int_real,first_real_fix,
first_fix_real,first_int_fix,first_real_real, first_fix_real,first_int_fix,first_real_real,
first_locmem,first_bool_byte,first_proc_to_procvar, first_locmem,first_bool_byte,first_proc_to_procvar,
@ -4492,7 +4494,11 @@ unit pass_1;
end. end.
{ {
$Log$ $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) * secondin bugfix (m68k and i386)
* overflow checking bugfix (m68k and i386) -- pretty useless in * overflow checking bugfix (m68k and i386) -- pretty useless in
secondadd, since everything is done using 32-bit secondadd, since everything is done using 32-bit

18
compiler/pbase.pas
View File

@ -39,6 +39,9 @@ unit pbase;
getprocvar : boolean = false; getprocvar : boolean = false;
getprocvardef : pprocvardef = nil; getprocvardef : pprocvardef = nil;
type
tblock_type = (bt_general,bt_type,bt_const);
var var
{ contains the current token to be processes } { contains the current token to be processes }
token : ttoken; token : ttoken;
@ -59,6 +62,12 @@ unit pbase;
{ true, if we are in a except block } { true, if we are in a except block }
in_except_block : boolean; 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 } { consumes token i, if the current token is unequal i }
{ a syntax error is written } { a syntax error is written }
@ -77,7 +86,6 @@ unit pbase;
{ sc is disposed } { sc is disposed }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef); procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
implementation implementation
@ -197,8 +205,12 @@ end.
{ {
$Log$ $Log$
Revision 1.1 1998-03-25 11:18:14 root Revision 1.2 1998-04-07 22:45:05 florian
Initial revision * 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 Revision 1.9 1998/03/10 01:17:23 peter
* all files have the same header * 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 { this was missed, so const s : ^string = nil gives an
error (FK) error (FK)
} }
parse_types:=true; block_type:=bt_type;
consume(COLON); consume(COLON);
ignore_equal:=true;
def:=read_type(''); def:=read_type('');
block_type:=bt_type;
ignore_equal:=false;
symtablestack^.insert(new(ptypedconstsym,init(name,def))); symtablestack^.insert(new(ptypedconstsym,init(name,def)));
parse_types:=false;
consume(EQUAL); consume(EQUAL);
readtypedconst(def); readtypedconst(def);
consume(SEMICOLON); consume(SEMICOLON);
@ -1037,7 +1039,6 @@ unit pdecl;
var var
hp1,p : pdef; hp1,p : pdef;
pt : ptree;
aufdef : penumdef; aufdef : penumdef;
aufsym : penumsym; aufsym : penumsym;
ap : parraydef; ap : parraydef;
@ -1045,16 +1046,37 @@ unit pdecl;
l,v,oldaktpackrecords : longint; l,v,oldaktpackrecords : longint;
hs : string; hs : string;
procedure range_type; procedure expr_type;
var
pt1,pt2 : ptree;
begin begin
{ it can be only a range type } { use of current parsed object ? }
pt:=expr; if (token=ID) and (testcurobject=2) and (curobjectname=pattern) then
do_firstpass(pt); 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 ? } { valid expression ? }
if (pt^.treetype<>rangen) or if (pt1^.treetype<>ordconstn) or
(pt^.left^.treetype<>ordconstn) then (pt2^.treetype<>ordconstn) then
Begin Begin
Message(sym_e_error_in_type_def); Message(sym_e_error_in_type_def);
{ Here we create a node type with a range of 0 } { Here we create a node type with a range of 0 }
@ -1063,46 +1085,17 @@ unit pdecl;
p:=new(porddef,init(uauto,0,0)); p:=new(porddef,init(uauto,0,0));
end end
else else
p:=new(porddef,init(uauto,pt^.left^.value,pt^.right^.value)); p:=new(porddef,init(uauto,pt1^.value,pt2^.value));
disposetree(pt); disposetree(pt2);
end;
disposetree(pt1);
end; end;
begin var
case token of pt : ptree;
ID,_STRING,_FILE:
p:=single_type(hs); procedure array_dec;
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:
begin begin
consume(_ARRAY); consume(_ARRAY);
consume(LECKKLAMMER); consume(LECKKLAMMER);
@ -1183,12 +1176,12 @@ unit pdecl;
if (pt^.treetype<>rangen) or if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then (pt^.left^.treetype<>ordconstn) then
Message(sym_e_error_in_type_def); Message(sym_e_error_in_type_def);
{ Registrierung der Grenzen erzwingen: } { force the registration of the ranges }
{$IfNdef GDB} {$ifndef GDB}
if pt^.right^.resulttype=pdef(s32bitdef) then if pt^.right^.resulttype=pdef(s32bitdef) then
pt^.right^.resulttype:=new(porddef,init( pt^.right^.resulttype:=new(porddef,init(
s32bit,$80000000,$7fffffff)); s32bit,$80000000,$7fffffff));
{$EndIf GDB} {$endif GDB}
if p=nil then if p=nil then
begin begin
ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype)); ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
@ -1212,6 +1205,44 @@ unit pdecl;
if assigned(ap) then if assigned(ap) then
ap^.definition:=hp1; ap^.definition:=hp1;
end; 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: _SET:
begin begin
consume(_SET); consume(_SET);
@ -1267,11 +1298,19 @@ unit pdecl;
_PACKED: _PACKED:
begin begin
consume(_PACKED); consume(_PACKED);
if token=_ARRAY then
array_dec
else
begin
oldaktpackrecords:=aktpackrecords; oldaktpackrecords:=aktpackrecords;
aktpackrecords:=1; aktpackrecords:=1;
if token in [_CLASS,_OBJECT] then
p:=object_dec(name,nil)
else
p:=record_dec; p:=record_dec;
aktpackrecords:=oldaktpackrecords; aktpackrecords:=oldaktpackrecords;
end; end;
end;
_CLASS, _CLASS,
_OBJECT: _OBJECT:
p:=object_dec(name,nil); p:=object_dec(name,nil);
@ -1288,7 +1327,7 @@ unit pdecl;
pprocvardef(p)^.retdef:=single_type(hs); pprocvardef(p)^.retdef:=single_type(hs);
end; end;
else else
range_type; expr_type;
end; end;
read_type:=p; read_type:=p;
end; end;
@ -1312,7 +1351,7 @@ unit pdecl;
{$endif dummy} {$endif dummy}
begin begin
parse_types:=true; block_type:=bt_type;
consume(_TYPE); consume(_TYPE);
typecanbeforward:=true; typecanbeforward:=true;
repeat repeat
@ -1363,7 +1402,7 @@ unit pdecl;
symtablestack^.foreach(@testforward_types); symtablestack^.foreach(@testforward_types);
{$endif} {$endif}
resolve_forwards; resolve_forwards;
parse_types:=false; block_type:=bt_general;
end; end;
{ parses varaible declarations and inserts them in } { parses varaible declarations and inserts them in }
@ -1400,14 +1439,14 @@ unit pdecl;
{ 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;
pt : ptree; pt : ptree;
old_parse_types : boolean; old_block_type : tblock_type;
{ to handle absolute } { to handle absolute }
abssym : pabsolutesym; abssym : pabsolutesym;
begin begin
hs:=''; hs:='';
old_parse_types:=parse_types; old_block_type:=block_type;
parse_types:=true; block_type:=bt_type;
while (token=ID) and while (token=ID) and
(pattern<>'PUBLIC') and (pattern<>'PUBLIC') and
(pattern<>'PRIVATE') and (pattern<>'PRIVATE') and
@ -1573,7 +1612,7 @@ unit pdecl;
{ at last set the record size to that of the biggest variant } { at last set the record size to that of the biggest variant }
symtablestack^.datasize:=maxsize; symtablestack^.datasize:=maxsize;
end; end;
parse_types:=old_parse_types; block_type:=old_block_type;
end; end;
procedure read_declarations(islibrary : boolean); procedure read_declarations(islibrary : boolean);
@ -1581,13 +1620,19 @@ unit pdecl;
begin begin
repeat repeat
case token of case token of
_LABEL : label_dec; _LABEL:
_CONST : const_dec; label_dec;
_TYPE : type_dec; _CONST:
_VAR : var_dec; const_dec;
_TYPE:
type_dec;
_VAR:
var_dec;
_CONSTRUCTOR,_DESTRUCTOR, _CONSTRUCTOR,_DESTRUCTOR,
_FUNCTION,_PROCEDURE,_OPERATOR,_CLASS : unter_dec; _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS:
_EXPORTS : if islibrary then unter_dec;
_EXPORTS:
if islibrary then
read_exports read_exports
else else
break; break;
@ -1621,7 +1666,11 @@ unit pdecl;
end. end.
{ {
$Log$ $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 * fixed the -Ss bug
+ warning for Virtual constructors + warning for Virtual constructors
* helppages updated with -TGO32V1 * helppages updated with -TGO32V1

40
compiler/pexpr.pas
View File

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

13
compiler/scanner.pas
View File

@ -150,8 +150,6 @@ unit scanner;
var var
pattern,orgpattern : string; pattern,orgpattern : string;
{ true, if type declarations are parsed }
parse_types : boolean;
{ macros } { macros }
@ -180,6 +178,9 @@ for the last instruction of an include file !}
implementation implementation
uses
pbase;
const const
newline = #10; newline = #10;
@ -1860,7 +1861,7 @@ for the last instruction of an include file !}
begin begin
nextchar; nextchar;
c:=upcase(c); 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 begin
pattern:=chr(ord(c)-64); pattern:=chr(ord(c)-64);
nextchar; nextchar;
@ -2102,7 +2103,11 @@ for the last instruction of an include file !}
end. end.
{ {
$Log$ $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 * bugfixes for reset_gdb_info
in MEM parsing for go32v2 in MEM parsing for go32v2
better external symbol creation 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_s32bit_2_u32bit,tc_s16bit_2_u32bit,
tc_s8bit_2_u32bit,tc_u16bit_2_u32bit, tc_s8bit_2_u32bit,tc_u16bit_2_u32bit,
tc_u8bit_2_u32bit,tc_u32bit_2_s32bit, 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_int_2_real,tc_real_2_fix,
tc_fix_2_real,tc_int_2_fix,tc_real_2_real, tc_fix_2_real,tc_int_2_fix,tc_real_2_real,
tc_chararray_2_string,tc_bool_2_u8bit, tc_chararray_2_string,tc_bool_2_u8bit,
@ -1158,8 +1160,12 @@ $endif SUPPORT_MMX
end. end.
{ {
$Log$ $Log$
Revision 1.1 1998-03-25 11:18:13 root Revision 1.2 1998-04-07 22:45:05 florian
Initial revision * 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 Revision 1.15 1998/03/24 21:48:36 florian
* just a couple of fixes applied: * just a couple of fixes applied: