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

* fixed bugs 212,222,225,227,229,231,233

Browse Source
This commit is contained in:
peter 1999-03-24 23:16:42 +00:00
parent 2f73a8158d
commit d0cb5a147a
31 changed files with 1478 additions and 1299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
compiler/assemble.pas
View File

@ -79,7 +79,7 @@ var
Implementation
uses
script,files,systems,verbose,comphook
script,files,systems,verbose
{$ifdef linux}
,linux
{$endif}
@ -229,7 +229,7 @@ begin
else
begin
DoAssemble:=false;
inc(status.errorcount);
GenerateError;
end;
end;
@ -541,7 +541,10 @@ end;
end.
{
$Log$
Revision 1.40 1999-03-18 20:30:44 peter
Revision 1.41 1999-03-24 23:16:42 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.40 1999/03/18 20:30:44 peter
+ .a writer
Revision 1.39 1999/03/01 15:43:48 peter

7
compiler/browcol.pas
View File

@ -116,7 +116,7 @@ implementation
uses
Drivers,Views,App,
aasm,globtype,globals,files,comphook;
aasm,globtype,globals,files;
{****************************************************************************
Helpers
@ -900,7 +900,10 @@ begin
end.
{
$Log$
Revision 1.8 1999-03-03 01:38:11 pierre
Revision 1.9 1999-03-24 23:16:44 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.8 1999/03/03 01:38:11 pierre
* avoid infinite recursion in ProcessDefIfStruct
Revision 1.7 1999/02/22 11:51:32 peter

96
compiler/cg386cal.pas
View File

@ -57,20 +57,12 @@ implementation
push_from_left_to_right,inlined : boolean;para_offset : longint);
procedure maybe_push_high;
{$ifdef OLDHIGH}
var
r : preference;
hreg : tregister;
href : treference;
len : longint;
{$endif}
begin
{ open array ? }
{ defcoll^.data can be nil for read/write }
if assigned(defcoll^.data) and
push_high_param(defcoll^.data) then
begin
{$ifndef OLDHIGH}
if assigned(p^.hightree) then
begin
secondpass(p^.hightree);
@ -78,89 +70,6 @@ implementation
end
else
internalerror(432645);
{$else}
{ push high }
case p^.left^.resulttype^.deftype of
arraydef : begin
if is_open_array(p^.left^.resulttype) then
begin
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
r:=new_reference(highframepointer,highoffset+4);
len:=-1;
end
else
len:=parraydef(p^.left^.resulttype)^.highrange-
parraydef(p^.left^.resulttype)^.lowrange
end;
stringdef : begin
if is_open_string(defcoll^.data) then
begin
if is_open_string(p^.left^.resulttype) then
begin
r:=new_reference(highframepointer,highoffset+4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
hreg:=R_EDI;
len:=-2;
end
else
len:=pstringdef(p^.left^.resulttype)^.len
end
else
{ passing a string to an array of char }
begin
if (p^.left^.treetype=stringconstn) then
len:=str_length(p^.left)
else
begin
href:=p^.location.reference;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(href),R_EDI)));
hreg:=R_EDI;
len:=-2;
end;
end;
end;
else
len:=0;
end;
{ Push from the reference? }
if len=-1 then
begin
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r)));
end
else
{ Push from a register? }
if len=-2 then
begin
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hreg)));
ungetregister32(hreg);
end
else
{ Push direct value }
begin
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,len,r)));
end
else
push_int(len);
end;
inc(pushedparasize,4);
{$endif OLDHIGH}
end;
end;
@ -1308,7 +1217,10 @@ implementation
end.
{
$Log$
Revision 1.69 1999-02-25 21:02:21 peter
Revision 1.70 1999-03-24 23:16:46 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.69 1999/02/25 21:02:21 peter
* ag386bin updates
+ coff writer

102
compiler/cg386inl.pas
View File

@ -903,78 +903,39 @@ implementation
exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
p^.location.register:=reg16toreg8(p^.location.register);
end;
{$ifdef OLDHIGH}
in_high_x :
begin
if is_open_array(p^.left^.resulttype) or
is_open_string(p^.left^.resulttype) then
begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
r:=new_reference(highframepointer,highoffset+4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
r,p^.location.register)));
end
end;
{$endif OLDHIGH}
in_sizeof_x,
in_typeof_x :
begin
{$ifdef OLDHIGH}
{ sizeof(openarray) handling }
if (p^.inlinenumber=in_sizeof_x) and
(is_open_array(p^.left^.resulttype) or
is_open_string(p^.left^.resulttype)) then
begin
{ sizeof(openarray)=high(openarray)+1 }
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
r:=new_reference(highframepointer,highoffset+4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
r,p^.location.register)));
exprasmlist^.concat(new(pai386,op_reg(A_INC,S_L,
p^.location.register)));
if (p^.left^.resulttype^.deftype=arraydef) and
(parraydef(p^.left^.resulttype)^.elesize<>1) then
exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,
parraydef(p^.left^.resulttype)^.elesize,p^.location.register)));
end
{ for both cases load vmt }
if p^.left^.treetype=typen then
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
p^.location.register)));
end
else
{$endif OLDHIGH}
begin
{ for both cases load vmt }
if p^.left^.treetype=typen then
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
p^.location.register)));
end
else
begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
{ load VMT pointer }
inc(p^.left^.location.reference.offset,
pobjectdef(p^.left^.resulttype)^.vmt_offset);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
{ in sizeof load size }
if p^.inlinenumber=in_sizeof_x then
begin
new(r);
reset_reference(r^);
r^.base:=p^.location.register;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
p^.location.register)));
end;
end;
begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
{ load VMT pointer }
inc(p^.left^.location.reference.offset,
pobjectdef(p^.left^.resulttype)^.vmt_offset);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
{ in sizeof load size }
if p^.inlinenumber=in_sizeof_x then
begin
new(r);
reset_reference(r^);
r^.base:=p^.location.register;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
p^.location.register)));
end;
end;
in_lo_long,
in_hi_long :
@ -1309,7 +1270,10 @@ implementation
end.
{
$Log$
Revision 1.30 1999-03-16 17:52:56 jonas
Revision 1.31 1999-03-24 23:16:49 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.30 1999/03/16 17:52:56 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
* in cgai386: also small fixes to emitrangecheck

16
compiler/cg386ld.pas
View File

@ -83,7 +83,7 @@ implementation
begin
p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end
{ DLL variable }
else if (pvarsym(p^.symtableentry)^.var_options and vo_is_dll_var)<>0 then
@ -93,9 +93,14 @@ implementation
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister)));
p^.location.reference.symbol:=nil;
p^.location.reference.base:=hregister;
if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
end
{ external variable }
else if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
begin
p^.location.reference.symbol:=newasmsymbol(p^.symtableentry^.mangledname);
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end
{ normal variable }
else
begin
symtabletype:=p^.symtable^.symtabletype;
@ -797,7 +802,10 @@ implementation
end.
{
$Log$
Revision 1.45 1999-02-25 21:02:28 peter
Revision 1.46 1999-03-24 23:16:52 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.45 1999/02/25 21:02:28 peter
* ag386bin updates
+ coff writer

115
compiler/cg386mem.pas
View File

@ -46,7 +46,7 @@ implementation
globtype,systems,
cobjects,verbose,globals,
symtable,aasm,types,
hcodegen,temp_gen,pass_2,
hcodegen,temp_gen,pass_2,pass_1,
{$ifdef ag386bin}
i386base,i386asm,
{$else}
@ -408,9 +408,10 @@ implementation
rl : pdef;
t : ptree;
hp : preference;
href : treference;
tai : Pai386;
pushed : tpushed;
hightree : ptree;
begin
secondpass(p^.left);
@ -553,6 +554,7 @@ implementation
p:=_p;
end
else
{ not treetype=ordconstn }
begin
{ quick hack, to overcome Delphi 2 }
if (cs_regalloc in aktglobalswitches) and
@ -606,7 +608,8 @@ implementation
CGMessage(cg_e_illegal_expression);
is_pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if is_pushed then restore(p);
if is_pushed then
restore(p);
case p^.right^.location.loc of
LOC_REGISTER:
begin
@ -651,25 +654,33 @@ implementation
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case p^.right^.resulttype^.size of
1:
tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2:
tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4:
tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
1 : tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2 : tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4 : tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
end;
exprasmlist^.concat(tai);
end;
end;
{ produce possible range check code: }
if cs_check_range in aktlocalswitches then
begin
if cs_check_range in aktlocalswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
hp:=new_reference(R_NO,0);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring);
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
if is_open_array(p^.left^.resulttype) then
begin
reset_reference(href);
parraydef(p^.left^.resulttype)^.genrangecheck;
href.symbol:=newasmsymbol(parraydef(p^.left^.resulttype)^.getrangecheckstring);
href.offset:=4;
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hightree:=genloadnode(pvarsym(srsym),p^.left^.symtable);
firstpass(hightree);
secondpass(hightree);
emit_mov_loc_ref(hightree^.location,href);
disposetree(hightree);
end;
emitrangecheck(p^.right,p^.left^.resulttype);
end
else if (p^.left^.resulttype^.deftype=stringdef) then
begin
@ -687,56 +698,55 @@ implementation
popusedregisters(pushed);
maybe_loadesi;
end;
st_shortstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
st_longstring:
begin
{!!!!!!!!!!!!!!!!!}
end;
end;
end;
end;
end;
if p^.location.reference.index=R_NO then
begin
if p^.location.reference.index=R_NO then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
end
else
begin
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
p^.location.reference.symbol:=nil;
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
if p^.memseg then
p^.location.reference.segment:=R_FS;
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
p^.location.reference.symbol:=nil;
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
if p^.memseg then
p^.location.reference.segment:=R_FS;
end;
{ have we to remove a temp. wide/ansistring ?
@ -859,7 +869,10 @@ implementation
end.
{
$Log$
Revision 1.31 1999-02-25 21:02:29 peter
Revision 1.32 1999-03-24 23:16:53 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.31 1999/02/25 21:02:29 peter
* ag386bin updates
+ coff writer

572
compiler/hcgdata.pas Normal file
View File

@ -0,0 +1,572 @@
{
$Id$
Copyright (c) 1996-98 by Florian Klaempfl
Routines for the code generation of data structures
like VMT,Messages
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit hcgdata;
interface
uses
symtable,aasm;
{ generates the message tables for a class }
function genstrmsgtab(_class : pobjectdef) : plabel;
function genintmsgtab(_class : pobjectdef) : plabel;
{ generates a VMT for _class }
procedure genvmt(_class : pobjectdef);
implementation
uses
strings,cobjects,
globtype,globals,verbose,
types,
hcodegen;
{*****************************************************************************
Message
*****************************************************************************}
type
pprocdeftree = ^tprocdeftree;
tprocdeftree = record
p : pprocdef;
nl : plabel;
l,r : pprocdeftree;
end;
var
root : pprocdeftree;
count : longint;
procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
var
i : longint;
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
if i<0 then
insertstr(p,at^.l)
else if i>0 then
insertstr(p,at^.r)
else
Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
end;
end;
procedure disposeprocdeftree(p : pprocdeftree);
begin
if assigned(p^.l) then
disposeprocdeftree(p^.l);
if assigned(p^.r) then
disposeprocdeftree(p^.r);
dispose(p);
end;
procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}
var
hp : pprocdef;
pt : pprocdeftree;
begin
if p^.typ=procsym then
begin
hp:=pprocsym(p)^.definition;
while assigned(hp) do
begin
if (hp^.options and pomsgstr)<>0 then
begin
new(pt);
pt^.p:=hp;
pt^.l:=nil;
pt^.r:=nil;
insertstr(pt,root);
end;
hp:=hp^.nextoverloaded;
end;
end;
end;
procedure insertint(p : pprocdeftree;var at : pprocdeftree);
var
i : longint;
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
if p^.p^.messageinf.i<at^.p^.messageinf.i then
insertstr(p,at^.l)
else if p^.p^.messageinf.i>at^.p^.messageinf.i then
insertstr(p,at^.r)
else
Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
end;
end;
procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}
var
hp : pprocdef;
pt : pprocdeftree;
begin
if p^.typ=procsym then
begin
hp:=pprocsym(p)^.definition;
while assigned(hp) do
begin
if (hp^.options and pomsgint)<>0 then
begin
new(pt);
pt^.p:=hp;
pt^.l:=nil;
pt^.r:=nil;
insertint(pt,root);
end;
hp:=hp^.nextoverloaded;
end;
end;
end;
procedure writenames(p : pprocdeftree);
begin
getlabel(p^.nl);
if assigned(p^.l) then
writenames(p^.l);
datasegment^.concat(new(pai_label,init(p^.nl)));
datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
if assigned(p^.r) then
writenames(p^.r);
end;
procedure writestrentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writestrentry(p^.l);
{ write name label }
datasegment^.concat(new(pai_const_symbol,init(lab2str(p^.nl))));
datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
if assigned(p^.r) then
writestrentry(p^.r);
end;
function genstrmsgtab(_class : pobjectdef) : plabel;
var
r : plabel;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class^.publicsyms^.foreach(insertmsgstr);
{ write all names }
if assigned(root) then
writenames(root);
{ now start writing of the message string table }
getlabel(r);
datasegment^.concat(new(pai_label,init(r)));
genstrmsgtab:=r;
datasegment^.concat(new(pai_const,init_32bit(count)));
if assigned(root) then
begin
writestrentry(root);
disposeprocdeftree(root);
end;
end;
procedure writeintentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writeintentry(p^.l);
{ write name label }
datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
if assigned(p^.r) then
writeintentry(p^.r);
end;
function genintmsgtab(_class : pobjectdef) : plabel;
var
r : plabel;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class^.publicsyms^.foreach(insertmsgint);
{ now start writing of the message string table }
getlabel(r);
datasegment^.concat(new(pai_label,init(r)));
genintmsgtab:=r;
datasegment^.concat(new(pai_const,init_32bit(count)));
if assigned(root) then
begin
writeintentry(root);
disposeprocdeftree(root);
end;
end;
{*****************************************************************************
VMT
*****************************************************************************}
type
pprocdefcoll = ^tprocdefcoll;
tprocdefcoll = record
next : pprocdefcoll;
data : pprocdef;
end;
psymcoll = ^tsymcoll;
tsymcoll = record
next : psymcoll;
name : pstring;
data : pprocdefcoll;
end;
var
wurzel : psymcoll;
nextvirtnumber : longint;
_c : pobjectdef;
has_constructor,has_virtual_method : boolean;
procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}
var
procdefcoll : pprocdefcoll;
hp : pprocdef;
symcoll : psymcoll;
_name : string;
stored : boolean;
{ creates a new entry in the procsym list }
procedure newentry;
begin
{ if not, generate a new symbol item }
new(symcoll);
symcoll^.name:=stringdup(sym^.name);
symcoll^.next:=wurzel;
symcoll^.data:=nil;
wurzel:=symcoll;
hp:=pprocsym(sym)^.definition;
{ inserts all definitions }
while assigned(hp) do
begin
new(procdefcoll);
procdefcoll^.data:=hp;
procdefcoll^.next:=symcoll^.data;
symcoll^.data:=procdefcoll;
{ if it's a virtual method }
if (hp^.options and povirtualmethod)<>0 then
begin
{ then it gets a number ... }
hp^.extnumber:=nextvirtnumber;
{ and we inc the number }
inc(nextvirtnumber);
has_virtual_method:=true;
end;
if (hp^.options and poconstructor)<>0 then
has_constructor:=true;
{ check, if a method should be overridden }
if (hp^.options and pooverridingmethod)<>0 then
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
{ next overloaded method }
hp:=hp^.nextoverloaded;
end;
end;
begin
{ put only sub routines into the VMT }
if sym^.typ=procsym then
begin
_name:=sym^.name;
symcoll:=wurzel;
while assigned(symcoll) do
begin
{ does the symbol already exist in the list ? }
if _name=symcoll^.name^ then
begin
{ walk through all defs of the symbol }
hp:=pprocsym(sym)^.definition;
while assigned(hp) do
begin
{ compare with all stored definitions }
procdefcoll:=symcoll^.data;
stored:=false;
while assigned(procdefcoll) do
begin
{ compare parameters }
if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
(
((procdefcoll^.data^.options and povirtualmethod)<>0) or
((hp^.options and povirtualmethod)<>0)
) then
begin
{ wenn sie gleich sind }
{ und eine davon virtual deklariert ist }
{ Fehler falls nur eine VIRTUAL }
if (procdefcoll^.data^.options and povirtualmethod)<>
(hp^.options and povirtualmethod) then
begin
{ in classes, we hide the old method }
if _c^.isclass then
begin
{ warn only if it is the first time,
we hide the method }
if _c=hp^._class then
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
newentry;
exit;
end
else
if _c=hp^._class then
begin
if (procdefcoll^.data^.options and povirtualmethod)<>0 then
Message1(parser_w_overloaded_are_not_both_virtual,_c^.name^+'.'+_name)
else
Message1(parser_w_overloaded_are_not_both_non_virtual,
_c^.name^+'.'+_name);
newentry;
exit;
end;
end;
{ check, if the overridden directive is set }
{ (povirtualmethod is set! }
{ class ? }
if _c^.isclass and
((hp^.options and pooverridingmethod)=0) then
begin
{ warn only if it is the first time,
we hide the method }
if _c=hp^._class then
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
newentry;
exit;
end;
{ error, if the return types aren't equal }
if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) and
not((procdefcoll^.data^.retdef^.deftype=objectdef) and
(hp^.retdef^.deftype=objectdef) and
(pobjectdef(procdefcoll^.data^.retdef)^.isclass) and
(pobjectdef(hp^.retdef)^.isclass) and
(pobjectdef(hp^.retdef)^.isrelated(pobjectdef(procdefcoll^.data^.retdef)))) then
Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
{ the flags have to match }
{ except abstract and override }
if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
(hp^.options and not(poabstractmethod or pooverridingmethod)) then
Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
{ now set the number }
hp^.extnumber:=procdefcoll^.data^.extnumber;
{ and exchange }
procdefcoll^.data:=hp;
stored:=true;
end;
procdefcoll:=procdefcoll^.next;
end;
{ if it isn't saved in the list }
{ we create a new entry }
if not(stored) then
begin
new(procdefcoll);
procdefcoll^.data:=hp;
procdefcoll^.next:=symcoll^.data;
symcoll^.data:=procdefcoll;
{ if the method is virtual ... }
if (hp^.options and povirtualmethod)<>0 then
begin
{ ... it will get a number }
hp^.extnumber:=nextvirtnumber;
inc(nextvirtnumber);
end;
{ check, if a method should be overridden }
if (hp^.options and pooverridingmethod)<>0 then
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
end;
hp:=hp^.nextoverloaded;
end;
exit;
end;
symcoll:=symcoll^.next;
end;
newentry;
end;
end;
procedure genvmt(_class : pobjectdef);
procedure do_genvmt(p : pobjectdef);
begin
{ start with the base class }
if assigned(p^.childof) then
do_genvmt(p^.childof);
{ walk through all public syms }
_c:=_class;
{$ifdef tp}
p^.publicsyms^.foreach(eachsym);
{$else}
p^.publicsyms^.foreach(@eachsym);
{$endif}
end;
var
symcoll : psymcoll;
procdefcoll : pprocdefcoll;
i : longint;
begin
wurzel:=nil;
nextvirtnumber:=0;
has_constructor:=false;
has_virtual_method:=false;
{ generates a tree of all used methods }
do_genvmt(_class);
if has_virtual_method and not(has_constructor) then
Message1(parser_w_virtual_without_constructor,_class^.name^);
{ generates the VMT }
{ walk trough all numbers for virtual methods and search }
{ the method }
for i:=0 to nextvirtnumber-1 do
begin
symcoll:=wurzel;
{ walk trough all symbols }
while assigned(symcoll) do
begin
{ walk trough all methods }
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
{ writes the addresses to the VMT }
{ but only this which are declared as virtual }
if procdefcoll^.data^.extnumber=i then
begin
if (procdefcoll^.data^.options and povirtualmethod)<>0 then
begin
{ if a method is abstract, then is also the }
{ class abstract and it's not allow to }
{ generates an instance }
if (procdefcoll^.data^.options and poabstractmethod)<>0 then
begin
_class^.options:=_class^.options or oo_is_abstract;
datasegment^.concat(new(pai_const_symbol,
init('FPC_ABSTRACTERROR')));
end
else
begin
datasegment^.concat(new(pai_const_symbol,
init(procdefcoll^.data^.mangledname)));
maybe_concat_external(procdefcoll^.data^.owner,
procdefcoll^.data^.mangledname);
end;
end;
end;
procdefcoll:=procdefcoll^.next;
end;
symcoll:=symcoll^.next;
end;
end;
{ disposes the above generated tree }
symcoll:=wurzel;
while assigned(symcoll) do
begin
wurzel:=symcoll^.next;
stringdispose(symcoll^.name);
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
symcoll^.data:=procdefcoll^.next;
dispose(procdefcoll);
procdefcoll:=symcoll^.data;
end;
dispose(symcoll);
symcoll:=wurzel;
end;
end;
end.
{
$Log$
Revision 1.1 1999-03-24 23:17:00 peter
* fixed bugs 212,222,225,227,229,231,233
}

113
compiler/hcodegen.pas
View File

@ -25,7 +25,9 @@ unit hcodegen;
interface
uses
verbose,aasm,tree,symtable,cobjects
cobjects,
tokens,verbose,
aasm,symtable
{$ifdef i386}
{$ifdef ag386bin}
,i386base
@ -139,17 +141,8 @@ unit hcodegen;
{ save the size of pushed parameter, needed for aligning }
pushedparasize : longint;
{$ifdef OLDHIGH}
{ this is for open arrays and strings }
{ but be careful, this data is in the }
{ generated code destroyed quick, and also }
{ the next call of secondload destroys this }
{ data }
{ So be careful using the informations }
{ provided by this variables }
highframepointer : tregister;
highoffset : longint;
{$endif}
make_const_global : boolean;
temptoremove : plinkedlist;
{ message calls with codegenerror support }
procedure cgmessage(const t : tmsgconst);
@ -157,6 +150,8 @@ unit hcodegen;
procedure cgmessage2(const t : tmsgconst;const s1,s2 : string);
procedure cgmessage3(const t : tmsgconst;const s1,s2,s3 : string);
{ helpers }
procedure maybe_concat_external(symt : psymtable;const name : string);
{ initialize respectively terminates the code generator }
{ for a new module or procedure }
@ -165,21 +160,11 @@ unit hcodegen;
procedure codegen_newmodule;
procedure codegen_newprocedure;
{ counts the labels }
function case_count_labels(root : pcaserecord) : longint;
{ searches the highest label }
function case_get_max(root : pcaserecord) : longint;
{ searches the lowest label }
function case_get_min(root : pcaserecord) : longint;
var
make_const_global : boolean;
temptoremove : plinkedlist;
implementation
uses
systems,comphook,globals,files,strings;
systems,globals,files,strings;
{*****************************************************************************
override the message calls to set codegenerror
@ -191,9 +176,9 @@ implementation
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
olderrorcount:=Errorcount;
verbose.Message(t);
codegenerror:=olderrorcount<>status.errorcount;
codegenerror:=olderrorcount<>Errorcount;
end;
end;
@ -203,9 +188,9 @@ implementation
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
olderrorcount:=Errorcount;
verbose.Message1(t,s);
codegenerror:=olderrorcount<>status.errorcount;
codegenerror:=olderrorcount<>Errorcount;
end;
end;
@ -215,9 +200,9 @@ implementation
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
olderrorcount:=Errorcount;
verbose.Message2(t,s1,s2);
codegenerror:=olderrorcount<>status.errorcount;
codegenerror:=olderrorcount<>Errorcount;
end;
end;
@ -227,13 +212,28 @@ implementation
begin
if not(codegenerror) then
begin
olderrorcount:=status.errorcount;
olderrorcount:=Errorcount;
verbose.Message3(t,s1,s2,s3);
codegenerror:=olderrorcount<>status.errorcount;
codegenerror:=olderrorcount<>Errorcount;
end;
end;
{*****************************************************************************
Helpers
*****************************************************************************}
procedure maybe_concat_external(symt : psymtable;const name : string);
begin
if (symt^.symtabletype=unitsymtable) or
((symt^.symtabletype in [recordsymtable,objectsymtable]) and
(symt^.defowner^.owner^.symtabletype=unitsymtable)) or
((symt^.symtabletype=withsymtable) and
(symt^.defowner^.owner^.symtabletype=unitsymtable)) then
concat_external(name,EXT_NEAR);
end;
{*****************************************************************************
initialize/terminate the codegen for procedure and modules
*****************************************************************************}
@ -305,52 +305,6 @@ implementation
end;
{*****************************************************************************
Case Helpers
*****************************************************************************}
function case_count_labels(root : pcaserecord) : longint;
var
_l : longint;
procedure count(p : pcaserecord);
begin
inc(_l);
if assigned(p^.less) then
count(p^.less);
if assigned(p^.greater) then
count(p^.greater);
end;
begin
_l:=0;
count(root);
case_count_labels:=_l;
end;
function case_get_max(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.greater) do
hp:=hp^.greater;
case_get_max:=hp^._high;
end;
function case_get_min(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.less) do
hp:=hp^.less;
case_get_min:=hp^._low;
end;
{*****************************************************************************
TTempToDestroy
*****************************************************************************}
@ -366,7 +320,10 @@ end.
{
$Log$
Revision 1.27 1999-02-25 21:02:37 peter
Revision 1.28 1999-03-24 23:17:00 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.27 1999/02/25 21:02:37 peter
* ag386bin updates
+ coff writer

8
compiler/htypechk.pas
View File

@ -29,6 +29,7 @@ interface
const
{ firstcallparan without varspez we don't count the ref }
count_ref : boolean = true;
get_para_resulttype : boolean = false;
allow_array_constructor : boolean = false;
@ -55,7 +56,7 @@ implementation
uses
globtype,systems,tokens,
cobjects,verbose,globals,
aasm,types,
types,
hcodegen;
{****************************************************************************
@ -649,7 +650,10 @@ implementation
end.
{
$Log$
Revision 1.18 1999-03-06 17:25:19 peter
Revision 1.19 1999-03-24 23:17:02 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.18 1999/03/06 17:25:19 peter
* moved comp<->real warning so it doesn't occure everytime that
isconvertable is called with

2
compiler/msgidx.inc
View File

@ -419,6 +419,8 @@ type tmsgconst=(
assem_f_assembler_output_not_supported,
assem_e_unsupported_symbol_type,
assem_e_cannot_index_relative_var,
assem_h_direct_global_to_mangled,
assem_w_direct_global_is_overloaded_func,
exec_w_source_os_redefined,
exec_i_assembling_pipe,
exec_d_cant_create_asmfile,

142
compiler/msgtxt.inc
View File

@ -434,35 +434,37 @@ const msgtxt : array[0..00100,1..240] of char=(
'F_Selected assembler output not supported'#000+
'E_Unsupported symbol type for operand'#000+
'E_Cannot index a local var or parameter with a register'#000+
'W_Source operatin','g system redefined'#000+
'H_$1 translated t','o $2'#000+
'W_$1 is associated to an overloaded function'#000+
'W_Source operating system redefined'#000+
'I_Assembling (pipe) $1'#000+
'E_Can'#039't create assember file $1'#000+
'W_Assembler $1 not found, switching to external assembling'#000+
'T_Using assembler: $1'#000+
'W_Error while assembling exitcode $1'#000+
'W_Can'#039't call the assembler, error $1 switching t','o external assem'+
'bling'#000+
'W_Error while asse','mbling exitcode $1'#000+
'W_Can'#039't call the assembler, error $1 switching to external assembl'+
'ing'#000+
'I_Assembling $1'#000+
'W_Linker $1 not found, switching to external linking'#000+
'T_Using linker: $1'#000+
'W_Object $1 not found, Linking may fail !'#000+
'W_Library $1 not found, Linking may fail !'#000+
'W_Library $1 not foun','d, Linking may fail !'#000+
'W_Error while linking'#000+
'W_Can'#039't call the linker',', switching to external linking'#000+
'W_Can'#039't call the linker, switching to external linking'#000+
'I_Linking $1'#000+
'W_binder not found, switching to external binding'#000+
'W_ar not found, switching to external ar'#000+
'E_Dynamic Libraries not supported'#000+
'I_Closing script $1'#000+
'W_resource compiler not found, switching to extern','al mode'#000+
'I_C','losing script $1'#000+
'W_resource compiler not found, switching to external mode'#000+
'I_Compiling resource $1'#000+
'F_Can'#039't post process executable $1'#000+
'F_Can'#039't open executable $1'#000+
'X_Size of Code: $1 bytes'#000+
'X_Size of initialized data: $1 bytes'#000+
'X_Size of uninitialized data: $1 bytes'#000+
'X_Size of uniniti','alized data: $1 bytes'#000+
'X_Stack space reserved: $1 bytes'#000+
'X_Stack spac','e commited: $1 bytes'#000+
'X_Stack space commited: $1 bytes'#000+
'T_Unitsearch: $1'#000+
'T_PPU Loading $1'#000+
'U_PPU Name: $1'#000+
@ -470,199 +472,199 @@ const msgtxt : array[0..00100,1..240] of char=(
'U_PPU Crc: $1'#000+
'U_PPU Time: $1'#000+
'U_PPU File too short'#000+
'U_PPU Invalid Header (no PPU at the begin)'#000+
'U_PPU Invalid Header (no PPU at the b','egin)'#000+
'U_PPU Invalid Version $1'#000+
'U_PPU is compiled for an other proce','ssor'#000+
'U_PPU is compiled for an other processor'#000+
'U_PPU is compiled for an other target'#000+
'U_PPU Source: $1'#000+
'U_Writing $1'#000+
'F_Can'#039't Write PPU-File'#000+
'F_reading PPU-File'#000+
'F_unexpected end of PPU-File'#000+
'F_Invalid PPU-File entry: $1'#000+
'F_Invalid PPU-File entry: $1'#000,+
'F_PPU Dbx count problem'#000+
'E_Illegal unit name: $1'#000+
'F_Too much units'#000+
'F_','Circular unit reference between $1 and $2'#000+
'F_Circular unit reference between $1 and $2'#000+
'F_Can'#039't compile unit $1, no sources available'#000+
'W_Compiling the system unit requires the -Us switch'#000+
'F_There were $1 errors compiling module, stopping'#000+
'F_There were $1 errors compiling ','module, stopping'#000+
'U_Load from $1 ($2) unit $3'#000+
'U_Recompiling $1, chec','ksum changed for $2'#000+
'U_Recompiling $1, checksum changed for $2'#000+
'U_Recompiling unit, static lib is older than ppufile'#000+
'U_Recompiling unit, shared lib is older than ppufile'#000+
'U_Recompiling unit, obj and asm are older than ppufile'#000+
'U_Recompiling unit, obj and asm are older than ','ppufile'#000+
'U_Recompiling unit, obj is older than asm'#000+
'U_Parsing interfa','ce of $1'#000+
'U_Parsing interface of $1'#000+
'U_Parsing implementation of $1'#000+
'U_Second load for unit $1'#000+
'U_PPU Check file $1 time $2'#000+
'$1 [options] <inputfile> [options]'#000+
'W_Only one source file supported'#000+
'W_DEF file can be created only for OS/2'#000+
'E_nested response files are not suppor','ted'#000+
'W_DEF file ','can be created only for OS/2'#000+
'E_nested response files are not supported'#000+
'F_No source file name in command line'#000+
'E_Illegal parameter: $1'#000+
'H_-? writes help pages'#000+
'F_Too many config files nested'#000+
'F_Unable to open file $1'#000+
'N_Reading further options from $1'#000+
'N_Reading further options fr','om $1'#000+
'W_Target is already set to: $1'#000+
'W_Shared libs not supported on',' DOS platform, reverting to static'#000+
'W_Shared libs not supported on DOS platform, reverting to static'#000+
'F_too many IF(N)DEFs'#000+
'F_too many ENDIFs'#000+
'F_open conditional at the end of the file'#000+
'W_Debug information generation is not supported by this executable'#000+
'W_Debug information generation is not supported by this e','xecutable'#000+
'H_Try recompiling with -dGDB'#000+
'W_You are using the obsolete',' switch $1'#000+
'W_You are using the obsolete switch $1'#000+
'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
'Copyright (c) 1993-98 by Florian Klaempfl'#000+
'Free Pascal Compiler version $FPCVER'#000+
#000+
'Compiler Date : $FPCDATE'#000+
'Compiler Date : $F','PCDATE'#000+
'Compiler Target: $FPCTARGET'#000+
#000+
'This program comes under the GN','U General Public Licence'#000+
'This program comes under the GNU General Public Licence'#000+
'For more information read COPYING.FPC'#000+
#000+
'Report bugs,suggestions etc to:'#000+
' fpc-devel@vekoll.saturnus.vein.hu'#000+
'**0*_put + after a boolean switch option to enable it, - to disable it'+
#000+
'**1a_the compiler does','n'#039't delete the generated assembler file'#000+
'**0*_put + after a boolean',' switch option to enable it, - to disable '+
'it'#000+
'**1a_the compiler doesn'#039't delete the generated assembler file'#000+
'**2al_list sourcecode lines in assembler file'#000+
'**1b_generate browser info'#000+
'**2bl_generate local symbol info'#000+
'**1B_build all modules'#000+
'**1C_code generation options'#000+
'**1C','_code generation options'#000+
'3*2CD_create dynamic library'#000+
'**2Ch<n>_<n> ','bytes heap (between 1023 and 67107840)'#000+
'**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#000+
'**2Ci_IO-checking'#000+
'**2Cn_omit linking stage'#000+
'**2Co_check overflow of integer operations'#000+
'**2Cr_range checking'#000+
'**2Cs<n>_set stack size to <n>'#000+
'**2Cs<n>_set stack size to ','<n>'#000+
'**2Ct_stack checking'#000+
'3*2CS_create static library'#000+
'3*2Cx_use smar','tlinking'#000+
'3*2Cx_use smartlinking'#000+
'**1d<x>_defines the symbol <x>'#000+
'*O1D_generate a DEF file'#000+
'*O2Dd<x>_set description to <x>'#000+
'*O2Dw_PM application'#000+
'**1e<x>_set path to executable'#000+
'**1E_same as -Cn'#000+
'**1F_set file names and paths'#000+
'**2FD<x>_sets the directory where to search ','for compiler utilities'#000+
'**1F_se','t file names and paths'#000+
'**2FD<x>_sets the directory where to search for compiler utilities'#000+
'**2Fe<x>_redirect error output to <x>'#000+
'**2FE<x>_set exe/unit output path to <x>'#000+
'*L2Fg<x>_same as -Fl'#000+
'**2Fi<x>_adds <x> to include path'#000+
'**2Fl<x>_adds <x> to library path'#000+
'**2Fl<x>_adds <x','> to library path'#000+
'*L2FL<x>_uses <x> as dynamic linker'#000+
'**2Fo<x>_adds',' <x> to object path'#000+
'**2Fo<x>_adds <x> to object path'#000+
'**2Fr<x>_load error message file <x>'#000+
'**2Fu<x>_adds <x> to unit path'#000+
'**2FU<x>_set unit output path to <x>, overrides -FE'#000+
'*g1g_generate debugger information'#000+
'*g1g_generate debugger informatio','n'#000+
'*g2gg_use gsym'#000+
'*g2gd_use dbx'#000+
'*g2gh_use heap trace unit'#000+
'**1i_infor','mation'#000+
'**1i_information'#000+
'**2iD_return compiler date'#000+
'**2iV_return compiler version'#000+
'**2iSO_return source OS'#000+
'**2iSP_return source processor'#000+
'**2iTO_return target OS'#000+
'**2iTP_return target processor'#000+
'**2iTP_return target processor',#000+
'**1I<x>_adds <x> to include path'#000+
'**1k<x>_Pass <x> to the linker'#000+
'**','1l_write logo'#000+
'**1l_write logo'#000+
'**1n_don'#039't read the default config file'#000+
'**1o<x>_change the name of the executable produced to <x>'#000+
'**1pg_generate profile code for gprof'#000+
'*L1P_use pipes instead of creating temporary assembler files'#000+
'*L1P_use pipes instead ','of creating temporary assembler files'#000+
'**1S_syntax options'#000+
'**2S2_swi','tch some Delphi 2 extensions on'#000+
'**2S2_switch some Delphi 2 extensions on'#000+
'**2Sc_supports operators like C (*=,+=,/= and -=)'#000+
'**2Sd_tries to be Delphi compatible'#000+
'**2Se_compiler stops after the first error'#000+
'**2Sg_allow LABEL and GOTO'#000+
'**2Sg_allow ','LABEL and GOTO'#000+
'**2Sh_Use ansistrings'#000+
'**2Si_support C++ stlyed INLIN','E'#000+
'**2Si_support C++ stlyed INLINE'#000+
'**2Sm_support macros like C (global)'#000+
'**2So_tries to be TP/BP 7.0 compatible'#000+
'**2Sp_tries to be gpc compatible'#000+
'**2Ss_constructor name must be init (destructor must be done)'#000+
'**2Ss_constructor name must be init (destructor must be done)'#000,+
'**2St_allow static keyword in objects'#000+
'**1s_don'#039't call assembler and',' linker (only with -a)'#000+
'**1s_don'#039't call assembler and linker (only with -a)'#000+
'**1u<x>_undefines the symbol <x>'#000+
'**1U_unit options'#000+
'**2Un_don'#039't check the unit name'#000+
'**2Up<x>_same as -Fu<x>'#000+
'**2Us_compile a system unit'#000+
'**1v<x>_Be verbose. <x> is a combination of the following letters :'#000+
'**2*_e : Show ','errors (default) d : Show debug info'#000+
'**1v<x>_Be verb','ose. <x> is a combination of the following letters :'#000+
'**2*_e : Show errors (default) d : Show debug info'#000+
'**2*_w : Show warnings u : Show unit info'#000+
'**2*_n : Show notes t : Show tried/used files'#000+
'**2*_h : Show hints m : Show defined macros'#000+
'**2*_i : Show gen','eral info p : Show compiled procedures'#000+
'**2*_h : Sh','ow hints m : Show defined macros'#000+
'**2*_i : Show general info p : Show compiled procedures'#000+
'**2*_l : Show linenumbers c : Show conditionals'#000+
'**2*_a : Show everything 0 : Show nothing (except errors)'#000+
'**2*_b : Show all procedure r : Rhide/GCC compatibili','ty mod'+
'e'#000+
'**2*_a : Show everything 0 : Show nothing (except err','ors'+
')'#000+
'**2*_b : Show all procedure r : Rhide/GCC compatibility mode'#000+
'**2*_ declarations if an error x : Executable info (Win32 only)'#000+
'**2*_ occurs'#000+
'**1X_executable options'#000+
'*L2Xc_link with the c library'#000+
'**2XD_link with dynamic libraries (defines FPC_LINK_DYNAMIC)'#000+
'**2Xs_strip all symbols from ex','ecutable'#000+
'**2XD_link with dynamic l','ibraries (defines FPC_LINK_DYNAMIC)'#000+
'**2Xs_strip all symbols from executable'#000+
'**2XS_link with static libraries (defines FPC_LINK_STATIC)'#000+
'**0*_Processor specific options:'#000+
'3*1A<x>_output format'#000+
'3*2Ao_coff file using GNU AS'#000+
'3*2Anasmcoff_coff file using Nasm'#000+
'3*2Anasmcoff_coff fil','e using Nasm'#000+
'3*2Anasmelf_elf32 (linux) file using Nasm'#000+
'3*2Anasmobj_','obj file using Nasm'#000+
'3*2Anasmobj_obj file using Nasm'#000+
'3*2Amasm_obj using Masm (Mircosoft)'#000+
'3*2Atasm_obj using Tasm (Borland)'#000+
'3*1R<x>_assembler reading style'#000+
'3*2Ratt_read AT&T style assembler'#000+
'3*2Rintel_read Intel style assembler'#000+
'3*2Rdirect_copy assembler text directly to asse','mbler file'#000+
'3*2Rintel_read In','tel style assembler'#000+
'3*2Rdirect_copy assembler text directly to assembler file'#000+
'3*1O<x>_optimizations'#000+
'3*2Og_generate smaller code'#000+
'3*2OG_generate faster code (default)'#000+
'3*2Or_keep certain variables in registers (still BUGGY!!!)'#000+
'3*2Ou_enable uncertain optimizations (see docs)'#000+
'3*2O1_level 1 optimizations (quick ','optimizations)'#000+
'3*2Ou_enable unc','ertain optimizations (see docs)'#000+
'3*2O1_level 1 optimizations (quick optimizations)'#000+
'3*2O2_level 2 optimizations (-O1 + slower optimizations)'#000+
'3*2O3_level 3 optimizations (same as -O2u)'#000+
'3*2Op_target processor'#000+
'3*3Op1_set target processor to 386/486'#000+
'3*3Op1_set target processor to 386/','486'#000+
'3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000+
'3*3Op3_s','et target processor to PPro/PII/c6x86/K6 (tm)'#000+
'3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#000+
'3*1T<x>_Target operating system'#000+
'3*2TGO32V1_version 1 of DJ Delorie DOS extender'#000+
'3*2TGO32V2_version 2 of DJ Delorie DOS extender'#000+
'3*2TGO32V2_version 2 of DJ Delorie DOS extender',#000+
'3*2TLINUX_Linux'#000+
'3*2TOS2_OS/2 2.x'#000+
'3*2TWin32_Windows 32 Bit'#000+
'6*1A<x>_','output format'#000+
'6*1A<x>_output format'#000+
'6*2Ao_Unix o-file using GNU AS'#000+
'6*2Agas_GNU Motorola assembler'#000+
'6*2Amit_MIT Syntax (old GAS)'#000+
'6*2Amot_Standard Motorola assembler'#000+
'6*1O_optimizations'#000+
'6*2Oa_turn on the optimizer'#000+
'6*2Oa_turn on',' the optimizer'#000+
'6*2Og_generate smaller code'#000+
'6*2OG_generate faster co','de (default)'#000+
'6*2OG_generate faster code (default)'#000+
'6*2Ox_optimize maximum (still BUGGY!!!)'#000+
'6*2O2_set target processor to a MC68020+'#000+
'6*1R<x>_assembler reading style'#000+
'6*2RMOT_read motorola style assembler'#000+
'6*1T<x>_Target operating system'#000+
'6*1T<x>_T','arget operating system'#000+
'6*2TAMIGA_Commodore Amiga'#000+
'6*2TATARI_Atari ST','/STe/TT'#000+
'6*2TATARI_Atari ST/STe/TT'#000+
'6*2TMACOS_Macintosh m68k'#000+
'6*2TLINUX_Linux-68k'#000+
'**1*_'#000+

7
compiler/parser.pas
View File

@ -46,7 +46,7 @@ unit parser;
uses
globtype,version,tokens,systems,
cobjects,comphook,globals,verbose,
cobjects,globals,verbose,
symtable,files,aasm,hcodegen,
assemble,link,script,gendef,
{$ifdef BrowserLog}
@ -452,7 +452,10 @@ unit parser;
end.
{
$Log$
Revision 1.69 1999-02-25 21:02:40 peter
Revision 1.70 1999-03-24 23:17:10 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.69 1999/02/25 21:02:40 peter
* ag386bin updates
+ coff writer

7
compiler/pass_2.pas
View File

@ -42,7 +42,7 @@ implementation
uses
globtype,systems,
cobjects,verbose,comphook,globals,files,
cobjects,comphook,verbose,globals,files,
symtable,types,aasm,scanner,
pass_1,hcodegen,temp_gen
{$ifdef GDB}
@ -500,7 +500,10 @@ implementation
end.
{
$Log$
Revision 1.15 1999-02-22 02:15:25 peter
Revision 1.16 1999-03-24 23:17:11 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.15 1999/02/22 02:15:25 peter
* updates for ag386bin
Revision 1.14 1999/01/23 23:29:37 florian

93
compiler/pdecl.pas
View File

@ -56,7 +56,7 @@ unit pdecl;
uses
cobjects,scanner,aasm,tree,pass_1,strings,
files,types,hcodegen,verbose,systems,import
files,types,verbose,systems,import
{$ifdef GDB}
,gdb
{$endif GDB}
@ -73,6 +73,8 @@ unit pdecl;
{$ifdef m68k}
,m68k
{$endif}
{ codegen }
,hcodegen,hcgdata
;
function read_type(const name : stringid) : pdef;forward;
@ -121,8 +123,7 @@ unit pdecl;
old_block_type : tblock_type;
ps : pconstset;
pd : pbestreal;
sp : pstring;
l : longint;
sp : pchar;
begin
consume(_CONST);
old_block_type:=block_type;
@ -143,52 +144,38 @@ unit pdecl;
ordconstn:
begin
if is_constintnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constint,p^.value,nil)))
symtablestack^.insert(new(pconstsym,init_def(name,constint,p^.value,nil)))
else if is_constcharnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constchar,p^.value,nil)))
symtablestack^.insert(new(pconstsym,init_def(name,constchar,p^.value,nil)))
else if is_constboolnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constbool,p^.value,nil)))
symtablestack^.insert(new(pconstsym,init_def(name,constbool,p^.value,nil)))
else if p^.resulttype^.deftype=enumdef then
symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
else if p^.resulttype^.deftype=pointerdef then
symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype)))
else internalerror(111);
end;
stringconstn:
begin
if p^.length>255 then
l:=255
else
l:=p^.length;
{ value_str is disposed with p so I need a copy }
getmem(sp,l+1);
move(p^.value_str^,sp^[1],l);
{$ifndef TP}
{$ifopt H+}
setlength(sp^,l);
{$else}
sp^[0]:=chr(l);
{$endif}
{$else}
sp^[0]:=chr(l);
{$endif}
symtablestack^.insert(new(pconstsym,init(name,conststring,longint(sp),nil)));
getmem(sp,p^.length+1);
move(p^.value_str^,sp^,p^.length+1);
symtablestack^.insert(new(pconstsym,init_string(name,conststring,sp,p^.length)));
end;
realconstn :
begin
new(pd);
pd^:=p^.value_real;
symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd),nil)));
symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd))));
end;
setconstn :
begin
new(ps);
ps^:=p^.value_set^;
symtablestack^.insert(new(pconstsym,init(name,constset,longint(ps),p^.resulttype)));
symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype)));
end;
niln :
begin
symtablestack^.insert(new(pconstsym,init(name,constnil,0,p^.resulttype)));
symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype)));
end;
else
Message(cg_e_illegal_expression);
@ -644,7 +631,8 @@ unit pdecl;
s:=pattern;
consume(ID);
end;
if srsym^.typ<>typesym then
if not assigned(srsym) or
(srsym^.typ<>typesym) then
begin
Message(type_e_type_id_expected);
lasttypesym:=ptypesym(srsym);
@ -915,8 +903,26 @@ unit pdecl;
consume(_READ);
sym:=search_class_member(aktclass,pattern);
if not(assigned(sym)) then
Message1(sym_e_unknown_id,pattern)
begin
Message1(sym_e_unknown_id,pattern);
consume(ID);
end
else
begin
consume(ID);
if (token=POINT) and
((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
begin
consume(POINT);
getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
if not assigned(srsym) then
Message1(sym_e_illegal_field,pattern);
sym:=srsym;
consume(ID);
end;
end;
if assigned(sym) then
begin
{ varsym aren't allowed for an indexed property
or an property with parameters }
@ -945,15 +951,32 @@ unit pdecl;
end;
p^.readaccesssym:=sym;
end;
consume(ID);
end;
if (idtoken=_WRITE) then
begin
consume(_WRITE);
sym:=search_class_member(aktclass,pattern);
if not(assigned(sym)) then
Message1(sym_e_unknown_id,pattern)
begin
Message1(sym_e_unknown_id,pattern);
consume(ID);
end
else
begin
consume(ID);
if (token=POINT) and
((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then
begin
consume(POINT);
getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern);
if not assigned(srsym) then
Message1(sym_e_illegal_field,pattern);
sym:=srsym;
consume(ID);
end;
end;
if assigned(sym) then
begin
if ((sym^.typ=varsym) and
assigned(propertyparas)) or
@ -981,7 +1004,6 @@ unit pdecl;
end;
p^.writeaccesssym:=sym;
end;
consume(ID);
end;
if (idtoken=_STORED) then
begin
@ -2218,7 +2240,10 @@ unit pdecl;
end.
{
$Log$
Revision 1.103 1999-03-22 22:10:25 florian
Revision 1.104 1999-03-24 23:17:13 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.103 1999/03/22 22:10:25 florian
* typecanbeforward wasn't always restored in object_dec which
sometimes caused strange effects

45
compiler/pexpr.pas
View File

@ -88,7 +88,6 @@ unit pexpr;
begin
p1:=comp_expr(true);
p2:=gencallparanode(p1,p2);
{ it's for the str(l:5,s); }
if _colon and (token=COLON) then
begin
@ -813,6 +812,9 @@ unit pexpr;
---------------------------------------------}
procedure factor_read_id;
var
pc : pchar;
len : longint;
begin
{ allow post fix operators }
again:=true;
@ -1014,16 +1016,32 @@ unit pexpr;
end;
constsym : begin
case pconstsym(srsym)^.consttype of
constint : p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
conststring : p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
constchar : p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
constreal : p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^);
constbool : p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
constset : p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
psetdef(pconstsym(srsym)^.definition));
constord : p1:=genordinalconstnode(pconstsym(srsym)^.value,
pconstsym(srsym)^.definition);
constnil : p1:=genzeronode(niln);
constint :
p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
conststring :
begin
len:=pconstsym(srsym)^.len;
if not(cs_ansistrings in aktlocalswitches) and (len>255) then
len:=255;
getmem(pc,len+1);
move(pchar(pconstsym(srsym)^.value)^,pc^,len);
pc[len]:=#0;
p1:=genpcharconstnode(pc,len);
end;
constchar :
p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
constreal :
p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^);
constbool :
p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
constset :
p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
psetdef(pconstsym(srsym)^.definition));
constord :
p1:=genordinalconstnode(pconstsym(srsym)^.value,
pconstsym(srsym)^.definition);
constnil :
p1:=genzeronode(niln);
end;
pd:=p1^.resulttype;
end;
@ -1959,7 +1977,10 @@ unit pexpr;
end.
{
$Log$
Revision 1.87 1999-03-16 17:52:52 jonas
Revision 1.88 1999-03-24 23:17:15 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.87 1999/03/16 17:52:52 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
* in cgai386: also small fixes to emitrangecheck

25
compiler/pmodules.pas
View File

@ -738,7 +738,7 @@ unit pmodules;
function is_assembler_generated:boolean;
begin
is_assembler_generated:=(status.errorcount=0) and
is_assembler_generated:=(Errorcount=0) and
not(
codesegment^.empty and
datasegment^.empty and
@ -884,9 +884,9 @@ unit pmodules;
read_interface_declarations;
{ leave when we got an error }
if (status.errorcount>0) and not status.skip_error then
if (Errorcount>0) and not status.skip_error then
begin
Message1(unit_f_errors_in_unit,tostr(status.errorcount));
Message1(unit_f_errors_in_unit,tostr(Errorcount));
status.skip_error:=true;
exit;
end;
@ -1001,7 +1001,7 @@ unit pmodules;
{ absence does not matter here !! }
aktprocsym^.definition^.forwarddef:=false;
{ test static symtable }
if (status.errorcount=0) then
if (Errorcount=0) then
st^.allsymbolsused;
{ size of the static data }
@ -1033,7 +1033,7 @@ unit pmodules;
reset_global_defs;
{ tests, if all (interface) forwards are resolved }
if (status.errorcount=0) then
if (Errorcount=0) then
symtablestack^.check_forwards;
{ now we have a correct unit, change the symtable type }
@ -1044,9 +1044,9 @@ unit pmodules;
{$endif GDB}
{ leave when we got an error }
if (status.errorcount>0) and not status.skip_error then
if (Errorcount>0) and not status.skip_error then
begin
Message1(unit_f_errors_in_unit,tostr(status.errorcount));
Message1(unit_f_errors_in_unit,tostr(Errorcount));
status.skip_error:=true;
exit;
end;
@ -1063,7 +1063,7 @@ unit pmodules;
if cs_local_browser in aktmoduleswitches then
current_module^.localsymtable:=refsymtable;
{ Write out the ppufile }
if (status.errorcount=0) then
if (Errorcount=0) then
writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack));
{ must be done only after local symtable ref stores !! }
@ -1213,9 +1213,9 @@ unit pmodules;
write_gdb_info;
{$endIf Def New_GDB}
{ leave when we got an error }
if (status.errorcount>0) and not status.skip_error then
if (Errorcount>0) and not status.skip_error then
begin
Message1(unit_f_errors_in_unit,tostr(status.errorcount));
Message1(unit_f_errors_in_unit,tostr(Errorcount));
status.skip_error:=true;
exit;
end;
@ -1259,7 +1259,10 @@ unit pmodules;
end.
{
$Log$
Revision 1.103 1999-03-18 20:30:46 peter
Revision 1.104 1999-03-24 23:17:17 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.103 1999/03/18 20:30:46 peter
+ .a writer
Revision 1.102 1999/03/16 21:07:25 peter

10
compiler/ptconst.pas
View File

@ -36,7 +36,7 @@ unit ptconst;
uses
globtype,systems,tokens,
cobjects,globals,scanner,aasm,tree,pass_1,
hcodegen,types,verbose
types,verbose
{ parser specific stuff }
,pbase,pexpr
{ processor specific stuff }
@ -50,8 +50,11 @@ unit ptconst;
{$ifdef m68k}
,m68k
{$endif}
{ codegen }
,hcodegen,hcgdata
;
{ this procedure reads typed constants }
procedure readtypedconst(def : pdef;sym : ptypedconstsym);
@ -704,7 +707,10 @@ unit ptconst;
end.
{
$Log$
Revision 1.38 1999-02-25 21:02:45 peter
Revision 1.39 1999-03-24 23:17:21 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.38 1999/02/25 21:02:45 peter
* ag386bin updates
+ coff writer

32
compiler/ra386dir.pas
View File

@ -32,7 +32,7 @@ unit Ra386dir;
implementation
uses
comphook,files,hcodegen,globals,scanner,aasm
files,hcodegen,globals,scanner,aasm
{$ifdef Ag386Bin}
,i386base,i386asm
{$else}
@ -169,7 +169,10 @@ unit Ra386dir;
else
if (pos('MOV',upper(s)) > 0) and (pvarsym(sym)^.is_valid=0) then
Message1(sym_n_uninitialized_local_variable,hs);
hs:='-'+tostr(pvarsym(sym)^.address)+'('+att_reg2str[procinfo.framepointer]+')';
if ((pvarsym(sym)^.var_options and vo_is_external)<>0) then
hs:=pvarsym(sym)^.mangledname
else
hs:='-'+tostr(pvarsym(sym)^.address)+'('+att_reg2str[procinfo.framepointer]+')';
end
else
{ call to local function }
@ -212,20 +215,18 @@ unit Ra386dir;
begin
if (sym^.typ = varsym) or (sym^.typ = typedconstsym) then
begin
Do_comment(V_Warning,hs+' translated to '+sym^.mangledname);
Message2(assem_h_direct_global_to_mangled,hs,sym^.mangledname);
hs:=sym^.mangledname;
if sym^.typ=varsym then
inc(pvarsym(sym)^.refs);
end;
{ procs can be called or the address can be loaded }
if (sym^.typ=procsym) and ((pos('CALL',upper(s))>0) or
(pos('LEA',upper(s))>0)) then
if (sym^.typ=procsym) and
((pos('CALL',upper(s))>0) or (pos('LEA',upper(s))>0)) then
begin
if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
begin
Do_comment(V_Warning,hs+' is associated to an overloaded function');
end;
Do_comment(V_Warning,hs+' translated to '+sym^.mangledname);
Message1(assem_w_direct_global_is_overloaded_func,hs);
Message2(assem_h_direct_global_to_mangled,hs,sym^.mangledname);
hs:=sym^.mangledname;
end;
end
@ -242,11 +243,9 @@ unit Ra386dir;
begin
if assigned(procinfo.retdef) and
(procinfo.retdef<>pdef(voiddef)) then
begin
hs:=retstr;
end
hs:=retstr
else
Message(assem_w_void_function);
Message(assem_w_void_function);
end
else if upper(hs)='__OLDEBP' then
begin
@ -257,7 +256,7 @@ unit Ra386dir;
+'('+att_reg2str[procinfo.framepointer]+')'
else
Message(assem_e_cannot_use___OLDEBP_outside_nested_procedure);
end;
end;
end;
end;
end;
@ -296,7 +295,10 @@ unit Ra386dir;
end.
{
$Log$
Revision 1.15 1999-03-01 13:22:26 pierre
Revision 1.16 1999-03-24 23:17:22 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.15 1999/03/01 13:22:26 pierre
* varsym refs incremented
Revision 1.14 1999/02/22 02:15:36 peter

8
compiler/rautils.pas
View File

@ -1345,7 +1345,8 @@ end;
{ that the variable is valid. }
pvarsym(sym)^.is_valid:=1;
inc(pvarsym(sym)^.refs);
if pvarsym(sym)^.owner^.symtabletype=staticsymtable then
if (pvarsym(sym)^.owner^.symtabletype=staticsymtable) or
((pvarsym(sym)^.var_options and vo_is_external)<>0) then
begin
instr.operands[operandnum].ref.symbol:=newasmsymbol(pvarsym(sym)^.mangledname);
end
@ -1790,7 +1791,10 @@ end;
end.
{
$Log$
Revision 1.6 1999-03-01 13:22:25 pierre
Revision 1.7 1999-03-24 23:17:23 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.6 1999/03/01 13:22:25 pierre
* varsym refs incremented
Revision 1.5 1999/02/25 21:02:51 peter

53
compiler/scanner.pas
View File

@ -795,27 +795,33 @@ implementation
found:=0;
repeat
case c of
#26 : Message(scan_f_end_of_file);
'{' : begin
if comment_level=0 then
found:=1;
inc_comment_level;
end;
'}' : begin
dec_comment_level;
found:=0;
end;
'$' : begin
if found=1 then
found:=2;
end;
'(' : begin
readchar;
if c='*' then
skipoldtpcomment;
end;
else
found:=0;
#26 :
Message(scan_f_end_of_file);
'{' :
begin
if comment_level=0 then
found:=1;
inc_comment_level;
end;
'}' :
begin
dec_comment_level;
found:=0;
end;
'$' :
begin
if found=1 then
found:=2;
end;
'(' :
if (m_tp in aktmodeswitches) then
begin
readchar;
if c='*' then
skipoldtpcomment;
end;
else
found:=0;
end;
c:=inputpointer^;
if c=#0 then
@ -1575,7 +1581,10 @@ begin
end.
{
$Log$
Revision 1.75 1999-03-16 21:00:27 peter
Revision 1.76 1999-03-24 23:17:24 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.75 1999/03/16 21:00:27 peter
* fixed old tp comment behaviour within directives
Revision 1.74 1999/03/11 10:46:29 daniel

254
compiler/symsym.inc
View File

@ -409,7 +409,7 @@
oldaktfilepos : tfileposinfo;
begin
{ don't check if errors !! }
if status.errorcount>0 then
if Errorcount>0 then
exit;
pd:=definition;
while assigned(pd) do
@ -747,14 +747,14 @@
procedure tfuncretsym.write;
begin
(*
Normally all references are
transfered to the function symbol itself !! PM *)
tsym.write;
writedefref(funcretdef);
writelong(address);
current_ppu^.writeentry(ibfuncretsym);
end;
@ -770,6 +770,30 @@
end;
{$endif GDB}
procedure tfuncretsym.insert_in_data;
var
l : longint;
begin
{ allocate space in local if ret in acc or in fpu }
if ret_in_acc(procinfo.retdef) or (procinfo.retdef^.deftype=floatdef) then
begin
l:=funcretdef^.size;
inc(owner^.datasize,l);
{$ifdef m68k}
{ word alignment required for motorola }
if (l=1) then
inc(owner^.datasize,1)
else
{$endif}
if (l>=4) and ((owner^.datasize and 3)<>0) then
inc(owner^.datasize,4-(owner^.datasize and 3))
else if (l>=2) and ((owner^.datasize and 1)<>0) then
inc(owner^.datasize,2-(owner^.datasize and 1));
address:=owner^.datasize;
procinfo.retoffset:=-owner^.datasize;
end;
end;
{****************************************************************************
TABSOLUTESYM
@ -792,15 +816,18 @@
abstyp:=absolutetyp(readbyte);
absseg:=false;
case abstyp of
tovar : begin
asmname:=stringdup(readstring);
ref:=srsym;
end;
toasm : asmname:=stringdup(readstring);
toaddr : begin
address:=readlong;
absseg:=boolean(readbyte);
end;
tovar :
begin
asmname:=stringdup(readstring);
ref:=srsym;
end;
toasm :
asmname:=stringdup(readstring);
toaddr :
begin
address:=readlong;
absseg:=boolean(readbyte);
end;
end;
end;
@ -815,12 +842,15 @@
writebyte(var_options and (not vo_regable));
writebyte(byte(abstyp));
case abstyp of
tovar : writestring(ref^.name);
toasm : writestring(asmname^);
toaddr : begin
writelong(address);
writebyte(byte(absseg));
end;
tovar :
writestring(ref^.name);
toasm :
writestring(asmname^);
toaddr :
begin
writelong(address);
writebyte(byte(absseg));
end;
end;
current_ppu^.writeentry(ibabsolutesym);
end;
@ -846,9 +876,12 @@
function tabsolutesym.mangledname : string;
begin
case abstyp of
tovar : mangledname:=ref^.mangledname;
toasm : mangledname:=asmname^;
toaddr : mangledname:='$'+tostr(address);
tovar :
mangledname:=ref^.mangledname;
toasm :
mangledname:=asmname^;
toaddr :
mangledname:='$'+tostr(address);
else
internalerror(10002);
end;
@ -890,17 +923,17 @@
case p^.deftype of
pointerdef,
enumdef,
procvardef:
procvardef :
var_options:=var_options or vo_regable;
orddef: case porddef(p)^.typ of
u8bit,u16bit,u32bit,
bool8bit,bool16bit,bool32bit,
s8bit,s16bit,s32bit :
var_options:=var_options or vo_regable;
else
var_options:=var_options and not vo_regable;
end;
orddef :
case porddef(p)^.typ of
bool8bit,bool16bit,bool32bit,
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit :
var_options:=var_options or vo_regable;
else
var_options:=var_options and not vo_regable;
end;
setdef:
if psetdef(p)^.settype=smallset then
var_options:=var_options or vo_regable;
@ -989,15 +1022,17 @@
exit;
end;
case owner^.symtabletype of
staticsymtable : if (cs_smartlink in aktmoduleswitches) then
prefix:='_'+owner^.name^+'$$$_'
else
prefix:='_';
unitsymtable,
globalsymtable : prefix:='U_'+owner^.name^+'_';
staticsymtable :
if (cs_smartlink in aktmoduleswitches) then
prefix:='_'+owner^.name^+'$$$_'
else
prefix:='_';
unitsymtable,
globalsymtable :
prefix:='U_'+owner^.name^+'_';
else
Message(sym_e_invalid_call_tvarsymmangledname);
end;
end;
mangledname:=prefix+name;
end;
@ -1017,35 +1052,17 @@
begin
case varspez of
vs_var :
begin
{$ifdef OLDHIGH}
{ open arrays push also the high valye }
if is_open_array(definition) or
is_open_string(definition) then
getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
else
{$endif}
getpushsize:=target_os.size_of_pointer;
end;
getpushsize:=target_os.size_of_pointer;
vs_value,
vs_const :
begin
case definition^.deftype of
{$ifndef OLDHIGH}
arraydef,
{$endif OLDHIGH}
setdef,
stringdef,
recorddef,
objectdef :
getpushsize:=target_os.size_of_pointer;
{$ifdef OLDHIGH}
arraydef :
if is_open_array(definition) then
getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
else
getpushsize:=target_os.size_of_pointer;
{$endif OLDHIGH}
else
getpushsize:=definition^.size;
end;
@ -1424,13 +1441,36 @@
TCONSTSYM
****************************************************************************}
constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);
constructor tconstsym.init(const n : string;t : tconsttype;v : longint);
begin
tsym.init(n);
inherited init(n);
typ:=constsym;
definition:=def;
consttype:=t;
value:=v;
definition:=nil;
len:=0;
end;
constructor tconstsym.init_def(const n : string;t : tconsttype;v : longint;def : pdef);
begin
inherited init(n);
typ:=constsym;
consttype:=t;
value:=v;
definition:=def;
len:=0;
end;
constructor tconstsym.init_string(const n : string;t : tconsttype;str:pchar;l:longint);
begin
inherited init(n);
typ:=constsym;
consttype:=t;
value:=longint(str);
definition:=nil;
len:=l;
end;
@ -1443,28 +1483,36 @@
typ:=constsym;
consttype:=tconsttype(readbyte);
case consttype of
constint,
constint,
constbool,
constchar : value:=readlong;
constord : begin
definition:=readdefref;
value:=readlong;
end;
conststring : value:=longint(stringdup(readstring));
constreal : begin
new(pd);
pd^:=readreal;
value:=longint(pd);
end;
constset : begin
definition:=readdefref;
new(ps);
readnormalset(ps^);
value:=longint(ps);
end;
constnil : ;
else
Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
constord :
begin
definition:=readdefref;
value:=readlong;
end;
conststring :
begin
len:=readlong;
getmem(pchar(value),len+1);
current_ppu^.getdata(pchar(value)^,len);
end;
constreal :
begin
new(pd);
pd^:=readreal;
value:=longint(pd);
end;
constset :
begin
definition:=readdefref;
new(ps);
readnormalset(ps^);
value:=longint(ps);
end;
constnil : ;
else
Message1(unit_f_ppu_invalid_entry,tostr(ord(consttype)));
end;
end;
@ -1472,9 +1520,12 @@
destructor tconstsym.done;
begin
case consttype of
conststring : stringdispose(pstring(value));
constreal : dispose(pbestreal(value));
constset : dispose(pnormalset(value));
conststring :
freemem(pchar(value),len+1);
constreal :
dispose(pbestreal(value));
constset :
dispose(pnormalset(value));
end;
inherited done;
end;
@ -1498,20 +1549,28 @@
tsym.write;
writebyte(byte(consttype));
case consttype of
constnil : ;
constnil : ;
constint,
constbool,
constchar : writelong(value);
constord : begin
writedefref(definition);
writelong(value);
end;
conststring : writestring(pstring(value)^);
constreal : writereal(pbestreal(value)^);
constset : begin
writedefref(definition);
writenormalset(pointer(value)^);
end;
constchar :
writelong(value);
constord :
begin
writedefref(definition);
writelong(value);
end;
conststring :
begin
writelong(len);
current_ppu^.putdata(pchar(value)^,len);
end;
constreal :
writereal(pbestreal(value)^);
constset :
begin
writedefref(definition);
writenormalset(pointer(value)^);
end;
else
internalerror(13);
end;
@ -1811,7 +1870,10 @@
{
$Log$
Revision 1.74 1999-02-23 18:29:27 pierre
Revision 1.75 1999-03-24 23:17:27 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.74 1999/02/23 18:29:27 pierre
* win32 compilation error fix
+ some work for local browser (not cl=omplete yet)

15
compiler/symsymh.inc
View File

@ -234,6 +234,7 @@
constructor load;
procedure write;virtual;
procedure deref;virtual;
procedure insert_in_data;virtual;
{$ifdef GDB}
procedure concatstabto(asmlist : paasmoutput);virtual;
{$endif GDB}
@ -287,11 +288,14 @@
tconstsym = object(tsym)
definition : pdef;
consttype : tconsttype;
value : longint;
constructor init(const n : string;t : tconsttype;v : longint;def : pdef);
value,
len : longint; { len is needed for string length }
constructor init(const n : string;t : tconsttype;v : longint);
constructor init_def(const n : string;t : tconsttype;v : longint;def : pdef);
constructor init_string(const n : string;t : tconsttype;str:pchar;l:longint);
constructor load;
destructor done;virtual;
function mangledname : string;virtual;
destructor done;virtual;
procedure deref;virtual;
procedure write;virtual;
{$ifdef GDB}
@ -331,7 +335,10 @@
{
$Log$
Revision 1.15 1999-02-22 13:07:11 pierre
Revision 1.16 1999-03-24 23:17:29 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.15 1999/02/22 13:07:11 pierre
+ -b and -bl options work !
+ cs_local_browser ($L+) is disabled if cs_browser ($Y+)
is not enabled when quitting global section

9
compiler/systems.pas
View File

@ -277,7 +277,7 @@ implementation
stackalignment : 2;
size_of_pointer : 4;
size_of_longint : 4;
use_bound_instruction : true;
use_bound_instruction : false;
use_function_relative_addresses : true
),
(
@ -337,7 +337,7 @@ implementation
stackalignment : 4;
size_of_pointer : 4;
size_of_longint : 4;
use_bound_instruction : true;
use_bound_instruction : false;
use_function_relative_addresses : true
),
(
@ -1358,7 +1358,10 @@ begin
end.
{
$Log$
Revision 1.63 1999-03-09 11:54:09 pierre
Revision 1.64 1999-03-24 23:17:33 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.63 1999/03/09 11:54:09 pierre
* pecoff default assem for win32 with ag386bin
Revision 1.62 1999/03/04 13:55:48 pierre

20
compiler/tccal.pas
View File

@ -27,9 +27,7 @@ interface
symtable,tree;
{$ifndef OLDHIGH}
procedure gen_high_tree(p:ptree;openstring:boolean);
{$endif}
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
procedure firstcalln(var p : ptree);
@ -60,7 +58,6 @@ implementation
FirstCallParaN
*****************************************************************************}
{$ifndef OLDHIGH}
procedure gen_high_tree(p:ptree;openstring:boolean);
var
len : longint;
@ -120,11 +117,11 @@ implementation
p^.hightree:=genordinalconstnode(len,s32bitdef);
firstpass(p^.hightree);
end;
{$endif OLDHIGH}
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
var
old_get_para_resulttype : boolean;
old_array_constructor : boolean;
store_valid : boolean;
oldtype : pdef;
@ -146,10 +143,13 @@ implementation
if defcoll=nil then
begin
old_array_constructor:=allow_array_constructor;
old_get_para_resulttype:=get_para_resulttype;
get_para_resulttype:=true;
allow_array_constructor:=true;
if not(assigned(p^.resulttype)) or
(p^.left^.treetype=typeconvn) then
firstpass(p^.left);
get_para_resulttype:=old_get_para_resulttype;
allow_array_constructor:=old_array_constructor;
if codegenerror then
begin
@ -176,17 +176,18 @@ implementation
must_be_valid:=(defcoll^.paratyp<>vs_var);
{ only process typeconvn, else it will break other trees }
old_array_constructor:=allow_array_constructor;
old_get_para_resulttype:=get_para_resulttype;
allow_array_constructor:=true;
get_para_resulttype:=false;
if (p^.left^.treetype=typeconvn) then
firstpass(p^.left);
get_para_resulttype:=old_get_para_resulttype;
allow_array_constructor:=old_array_constructor;
must_be_valid:=store_valid;
end;
{ generate the high() value tree }
if push_high_param(defcoll^.data) then
{$ifndef OLDHIGH}
gen_high_tree(p,is_open_string(defcoll^.data));
{$endif}
if not(is_shortstring(p^.left^.resulttype) and
is_shortstring(defcoll^.data)) and
(defcoll^.data^.deftype<>formaldef) then
@ -870,7 +871,7 @@ implementation
if make_ref then
begin
procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@p^.fileinfo));
inc(procs^.data^.refcount);
inc(procs^.data^.refcount);
if procs^.data^.defref=nil then
procs^.data^.defref:=procs^.data^.lastref;
end;
@ -1119,7 +1120,10 @@ implementation
end.
{
$Log$
Revision 1.28 1999-03-23 14:43:03 peter
Revision 1.29 1999-03-24 23:17:34 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.28 1999/03/23 14:43:03 peter
* fixed crash with array of const in procvar
Revision 1.27 1999/03/19 17:31:54 pierre

34
compiler/tcflw.pas
View File

@ -235,7 +235,7 @@ implementation
var
old_t_times : longint;
hp : ptree;
begin
{ Calc register weight }
old_t_times:=t_times;
@ -250,6 +250,8 @@ implementation
exit;
end;
{ save counter var }
p^.t2:=getcopy(p^.left^.left);
p^.registers32:=p^.t1^.registers32;
p^.registersfpu:=p^.t1^.registersfpu;
@ -260,16 +262,6 @@ implementation
if p^.left^.treetype<>assignn then
CGMessage(cg_e_illegal_expression);
{ Laufvariable retten }
p^.t2:=getcopy(p^.left^.left);
{ Check count var }
if (p^.t2^.treetype<>loadn) then
CGMessage(cg_e_illegal_count_var)
else
if (not(is_ordinal(p^.t2^.resulttype))) then
CGMessage(type_e_ordinal_expr_expected);
cleartempgen;
must_be_valid:=false;
firstpass(p^.left);
@ -282,8 +274,23 @@ implementation
if p^.left^.registersmmx>p^.registersmmx then
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
{ process count var }
cleartempgen;
firstpass(p^.t2);
if codegenerror then
exit;
{ Check count var, record fields are also allowed in tp7 }
hp:=p^.t2;
while (hp^.treetype=subscriptn) do
hp:=hp^.left;
if (hp^.treetype<>loadn) then
CGMessage(cg_e_illegal_count_var)
else
if (not(is_ordinal(p^.t2^.resulttype))) then
CGMessage(type_e_ordinal_expr_expected);
if p^.t2^.registers32>p^.registers32 then
p^.registers32:=p^.t2^.registers32;
if p^.t2^.registersfpu>p^.registersfpu then
@ -493,7 +500,10 @@ implementation
end.
{
$Log$
Revision 1.7 1999-03-09 19:24:42 peter
Revision 1.8 1999-03-24 23:17:36 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.7 1999/03/09 19:24:42 peter
* type check the exit()
Revision 1.6 1999/02/22 02:15:48 peter

19
compiler/tcinl.pas
View File

@ -320,7 +320,6 @@ implementation
end;
in_sizeof_x:
begin
{$ifndef OLDHIGH}
if push_high_param(p^.left^.resulttype) then
begin
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
@ -333,7 +332,6 @@ implementation
p:=hp;
firstpass(p);
end;
{$endif OLDHIGH}
if p^.registers32<1 then
p^.registers32:=1;
p^.resulttype:=s32bitdef;
@ -945,17 +943,11 @@ implementation
begin
if is_open_array(p^.left^.resulttype) then
begin
{$ifndef OLDHIGH}
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
disposetree(p);
p:=hp;
firstpass(p);
{$else OLDHIGH}
p^.resulttype:=s32bitdef;
p^.registers32:=max(1,p^.registers32);
p^.location.loc:=LOC_REGISTER;
{$endif OLDHIGH}
end
else
begin
@ -979,17 +971,11 @@ implementation
begin
if is_open_string(p^.left^.resulttype) then
begin
{$ifndef OLDHIGH}
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
disposetree(p);
p:=hp;
firstpass(p);
{$else OLDHIGH}
p^.resulttype:=s32bitdef;
p^.registers32:=max(1,p^.registers32);
p^.location.loc:=LOC_REGISTER;
{$endif OLDHIGH}
end
else
begin
@ -1048,7 +1034,10 @@ implementation
end.
{
$Log$
Revision 1.20 1999-03-16 17:52:55 jonas
Revision 1.21 1999-03-24 23:17:37 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.20 1999/03/16 17:52:55 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
* in cgai386: also small fixes to emitrangecheck

50
compiler/tcld.pas
View File

@ -392,34 +392,37 @@ implementation
while assigned(hp) do
begin
firstpass(hp^.left);
case hp^.left^.resulttype^.deftype of
enumdef :
begin
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
firstpass(hp^.left);
end;
orddef :
begin
if is_integer(hp^.left^.resulttype) then
if not get_para_resulttype then
begin
case hp^.left^.resulttype^.deftype of
enumdef :
begin
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
firstpass(hp^.left);
end;
end;
floatdef :
begin
hp^.left:=gentypeconvnode(hp^.left,s80floatdef);
firstpass(hp^.left);
end;
stringdef :
begin
if p^.cargs then
orddef :
begin
hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
if is_integer(hp^.left^.resulttype) then
begin
hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
firstpass(hp^.left);
end;
end;
floatdef :
begin
hp^.left:=gentypeconvnode(hp^.left,s80floatdef);
firstpass(hp^.left);
end;
end;
end;
stringdef :
begin
if p^.cargs then
begin
hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
firstpass(hp^.left);
end;
end;
end;
end;
if (pd=nil) then
pd:=hp^.left^.resulttype
else
@ -468,7 +471,10 @@ implementation
end.
{
$Log$
Revision 1.19 1999-03-18 11:21:52 peter
Revision 1.20 1999-03-24 23:17:39 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.19 1999/03/18 11:21:52 peter
* convert only to s32bit if integer or enum
Revision 1.18 1999/03/16 21:02:10 peter

10
compiler/todo.txt
View File

@ -66,14 +66,14 @@ compiler version and your short cut.
- add strict var strings check $V switch ................ 0.99.1 (FK)
- make dec/inc internal.................................. 0.99.6 (PFV)
- make length internal................................... 0.99.7 (PFV)
- range checking for open arrays......................... 0.99.11 (PFV)
- method pointers (procedure of object) ................. 0.99.11 (FK)
- open strings, $P....................................... 0.99.10 (PFV)
- include/exclude........................................ 0.99.10 (PM)
- fix all bugs of the bug directory
- range checking for open arrays
- method pointers (procedure of object) ................ 0.99.11 (FK)
- sysutils unit for go32v2 (excpetions!)
- initialisation/finalization for units
- fixed data type
- add alignment $A switch
- $B
- open strings, $P
- include/exclude

73
compiler/tree.pas
View File

@ -313,6 +313,13 @@ unit tree;
function str_length(p : ptree) : longint;
function is_emptyset(p : ptree):boolean;
{ counts the labels }
function case_count_labels(root : pcaserecord) : longint;
{ searches the highest label }
function case_get_max(root : pcaserecord) : longint;
{ searches the lowest label }
function case_get_min(root : pcaserecord) : longint;
{$I innr.inc}
implementation
@ -820,7 +827,6 @@ unit tree;
p^.stringtype:=st_shortstring;
p^.resulttype:=cshortstringdef;
end;
genstringconstnode:=p;
end;
@ -851,8 +857,18 @@ unit tree;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=0;
{$endif SUPPORT_MMX}
p^.resulttype:=cshortstringdef;
p^.length:=length;
if (cs_ansistrings in aktlocalswitches) or
(length>255) then
begin
p^.stringtype:=st_ansistring;
p^.resulttype:=cansistringdef;
end
else
begin
p^.stringtype:=st_shortstring;
p^.resulttype:=cshortstringdef;
end;
p^.value_str:=s;
p^.lab_str:=nil;
genpcharconstnode:=p;
@ -1642,10 +1658,61 @@ unit tree;
end;
{*****************************************************************************
Case Helpers
*****************************************************************************}
function case_count_labels(root : pcaserecord) : longint;
var
_l : longint;
procedure count(p : pcaserecord);
begin
inc(_l);
if assigned(p^.less) then
count(p^.less);
if assigned(p^.greater) then
count(p^.greater);
end;
begin
_l:=0;
count(root);
case_count_labels:=_l;
end;
function case_get_max(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.greater) do
hp:=hp^.greater;
case_get_max:=hp^._high;
end;
function case_get_min(root : pcaserecord) : longint;
var
hp : pcaserecord;
begin
hp:=root;
while assigned(hp^.less) do
hp:=hp^.less;
case_get_min:=hp^._low;
end;
end.
{
$Log$
Revision 1.68 1999-03-02 18:24:25 peter
Revision 1.69 1999-03-24 23:17:41 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.68 1999/03/02 18:24:25 peter
* fixed overloading of array of char
Revision 1.67 1999/02/25 21:02:56 peter

805
compiler/types.pas
View File

@ -21,16 +21,20 @@
****************************************************************************
}
unit types;
interface
interface
uses
cobjects,globals,symtable,aasm;
cobjects,symtable;
type
tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
const
{ true if we must never copy this parameter }
never_copy_const_param : boolean = false;
{ returns true, if def defines an ordinal type }
function is_ordinal(def : pdef) : boolean;
@ -96,10 +100,6 @@ unit types;
{ true if a parameter is too large to copy and only the address is pushed }
function push_addr_param(def : pdef) : boolean;
{ true if we must never copy this parameter }
const
never_copy_const_param : boolean = false;
{ true, if def1 and def2 are semantical the same }
function is_equal(def1,def2 : pdef) : boolean;
@ -123,23 +123,18 @@ unit types;
{ returns the range of def }
procedure getrange(def : pdef;var l : longint;var h : longint);
{ generates a VMT for _class }
procedure genvmt(_class : pobjectdef);
{ generates the message tables for a class }
function genstrmsgtab(_class : pobjectdef) : plabel;
function genintmsgtab(_class : pobjectdef) : plabel;
{ some type helper routines for MMX support }
function is_mmx_able_array(p : pdef) : boolean;
{ returns the mmx type }
function mmx_type(p : pdef) : tmmxtype;
implementation
implementation
uses
strings,globtype,verbose;
strings,
globtype,globals,verbose;
function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
@ -215,9 +210,9 @@ unit types;
end;
end;
{ returns the min. value of the type }
function get_min_value(def : pdef) : longint;
begin
case def^.deftype of
orddef:
@ -354,7 +349,6 @@ unit types;
{ true if the return value is in accumulator (EAX for i386), D0 for 68k }
function ret_in_acc(def : pdef) : boolean;
begin
ret_in_acc:=(def^.deftype in [orddef,pointerdef,enumdef,classrefdef]) or
((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or
@ -364,13 +358,14 @@ unit types;
((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
end;
{ true, if def is a 64 bit int type }
function is_64bitint(def : pdef) : boolean;
begin
is_64bitint:=(def^.deftype=orddef) and (porddef(def)^.typ in [u64bit,s64bitint])
end;
{ true if uses a parameter as return value }
function ret_in_param(def : pdef) : boolean;
begin
@ -393,15 +388,16 @@ unit types;
begin
push_addr_param:=never_copy_const_param or
(def^.deftype = formaldef) or
((def^.deftype in [arraydef,recorddef])
{ copy directly small records or arrays unless
array of const ! PM }
{$ifndef COPY_SMALL_RECORDS}
and ((def^.size>4) or
((def^.deftype=arraydef) and
(parraydef(def)^.IsConstructor or
parraydef(def)^.isArrayOfConst)))
{$endif def COPY_SMALL_RECORDS}
{ copy directly small records or arrays unless array of const ! PM }
((def^.deftype in [arraydef,recorddef]) and
((def^.size>4) or
((def^.deftype=arraydef) and
(parraydef(def)^.IsConstructor or
parraydef(def)^.isArrayOfConst or
is_open_array(def)
)
)
)
) or
((def^.deftype=objectdef) and not(pobjectdef(def)^.isclass)) or
((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or
@ -457,14 +453,21 @@ unit types;
procedure getrange(def : pdef;var l : longint;var h : longint);
begin
case def^.deftype of
orddef : begin
l:=porddef(def)^.low;
h:=porddef(def)^.high;
end;
enumdef : begin
l:=penumdef(def)^.min;
h:=penumdef(def)^.max;
end;
orddef :
begin
l:=porddef(def)^.low;
h:=porddef(def)^.high;
end;
enumdef :
begin
l:=penumdef(def)^.min;
h:=penumdef(def)^.max;
end;
arraydef :
begin
l:=parraydef(def)^.lowrange;
h:=parraydef(def)^.highrange;
end;
else
internalerror(987);
end;
@ -501,8 +504,8 @@ unit types;
end;
end;
function is_mmx_able_array(p : pdef) : boolean;
function is_mmx_able_array(p : pdef) : boolean;
begin
{$ifdef SUPPORT_MMX}
if (cs_mmx_saturation in aktlocalswitches) then
@ -593,13 +596,12 @@ unit types;
{$endif SUPPORT_MMX}
end;
function is_equal(def1,def2 : pdef) : boolean;
function is_equal(def1,def2 : pdef) : boolean;
var
b : boolean;
hd : pdef;
hp1,hp2 : pdefcoll;
begin
{ both types must exists }
if not (assigned(def1) and assigned(def2)) then
@ -623,9 +625,9 @@ unit types;
else
{ pointer with an equal definition are equal }
if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
{ here a problem detected in tabsolutesym }
{ the types can be forward type !! }
begin
{ here a problem detected in tabsolutesym }
{ the types can be forward type !! }
if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
b:=(def1^.sym=def2^.sym)
else
@ -650,31 +652,23 @@ unit types;
if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
else
{ strings with the same length are equal }
if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
(pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
begin
b:=not(is_shortstring(def1)) or
(pstringdef(def1)^.len=pstringdef(def2)^.len);
end
{ STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
{
else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
(parraydef(def2)^.definition^.deftype=orddef) and
(porddef(parraydef(def1)^.definition)^.typ=uchar) and
(parraydef(def2)^.lowrange=0) and
(parraydef(def2)^.highrange=pstringdef(def1)^.len) then
b:=true }
else
if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
b:=true
{ file types with the same file element type are equal }
{ this is a problem for assign !! }
{ changed to allow if one is untyped }
{ all typed files are equal to the special }
{ typed file that has voiddef as elemnt type }
{ but must NOT match for text file !!! }
else
{ strings with the same length are equal }
if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
(pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
begin
b:=not(is_shortstring(def1)) or
(pstringdef(def1)^.len=pstringdef(def2)^.len);
end
else
if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
b:=true
{ file types with the same file element type are equal }
{ this is a problem for assign !! }
{ changed to allow if one is untyped }
{ all typed files are equal to the special }
{ typed file that has voiddef as elemnt type }
{ but must NOT match for text file !!! }
else
if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
((
@ -688,612 +682,109 @@ unit types;
( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
(pfiledef(def2)^.typed_as=pdef(voiddef))
)))
{ sets with the same element type are equal }
else
if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
begin
if assigned(psetdef(def1)^.setof) and
assigned(psetdef(def2)^.setof) then
b:=(psetdef(def1)^.setof^.deftype=psetdef(def2)^.setof^.deftype)
else
b:=true;
end
else
if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
begin
{ poassembler isn't important for compatibility }
{ if a method is assigned to a methodpointer }
{ is checked before }
b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
povirtualmethod or pooverridingmethod))=
(pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
povirtualmethod or pooverridingmethod))
) and
is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
{ now evalute the parameters }
if b then
begin
hp1:=pprocvardef(def1)^.para1;
hp2:=pprocvardef(def1)^.para1;
while assigned(hp1) and assigned(hp2) do
begin
if not(is_equal(hp1^.data,hp2^.data)) or
not(hp1^.paratyp=hp2^.paratyp) then
begin
b:=false;
break;
end;
hp1:=hp1^.next;
hp2:=hp2^.next;
end;
b:=(hp1=nil) and (hp2=nil);
end;
end
else
if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
(is_open_array(def1) or is_open_array(def2)) then
begin
if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
b:=true
{ sets with the same element type are equal }
else
if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
begin
if assigned(psetdef(def1)^.setof) and
assigned(psetdef(def2)^.setof) then
b:=(psetdef(def1)^.setof^.deftype=psetdef(def2)^.setof^.deftype)
else
b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
end
else
if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
begin
{ similar to pointerdef: }
if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
b:=(def1^.sym=def2^.sym)
else
b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
end;
b:=true;
end
else
if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
begin
{ poassembler isn't important for compatibility }
{ if a method is assigned to a methodpointer }
{ is checked before }
b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
povirtualmethod or pooverridingmethod))=
(pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
povirtualmethod or pooverridingmethod))
) and
is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
{ now evalute the parameters }
if b then
begin
hp1:=pprocvardef(def1)^.para1;
hp2:=pprocvardef(def1)^.para1;
while assigned(hp1) and assigned(hp2) do
begin
if not(is_equal(hp1^.data,hp2^.data)) or
not(hp1^.paratyp=hp2^.paratyp) then
begin
b:=false;
break;
end;
hp1:=hp1^.next;
hp2:=hp2^.next;
end;
b:=(hp1=nil) and (hp2=nil);
end;
end
else
if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
(is_open_array(def1) or is_open_array(def2)) then
begin
if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
b:=true
else
b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
end
else
if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
begin
{ similar to pointerdef: }
if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
b:=(def1^.sym=def2^.sym)
else
b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
end;
is_equal:=b;
end;
function is_subequal(def1, def2: pdef): boolean;
Begin
if assigned(def1) and assigned(def2) then
Begin
is_subequal := FALSE;
if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
Begin
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
{ range checking for case statements is done with testrange }
case porddef(def1)^.typ of
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit : is_subequal:=(porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
bool8bit,bool16bit,bool32bit : is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]);
uchar : is_subequal:=(porddef(def2)^.typ=uchar);
end;
end
else
Begin
{ I assume that both enumerations are equal when the first }
{ pointers are equal. }
if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
Begin
if penumdef(def1)^.first = penumdef(def2)^.first then
is_subequal := TRUE;
if assigned(def1) and assigned(def2) then
Begin
is_subequal := FALSE;
if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
Begin
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
{ range checking for case statements is done with testrange }
case porddef(def1)^.typ of
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit :
is_subequal:=(porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
bool8bit,bool16bit,bool32bit :
is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]);
uchar :
is_subequal:=(porddef(def2)^.typ=uchar);
end;
end;
end; { endif assigned ... }
end;
type
pprocdeftree = ^tprocdeftree;
tprocdeftree = record
p : pprocdef;
nl : plabel;
l,r : pprocdeftree;
end;
var
root : pprocdeftree;
count : longint;
procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
var
i : longint;
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
if i<0 then
insertstr(p,at^.l)
else if i>0 then
insertstr(p,at^.r)
else
Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
end;
end;
procedure disposeprocdeftree(p : pprocdeftree);
begin
if assigned(p^.l) then
disposeprocdeftree(p^.l);
if assigned(p^.r) then
disposeprocdeftree(p^.r);
dispose(p);
end;
procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}
var
hp : pprocdef;
pt : pprocdeftree;
begin
if p^.typ=procsym then
begin
hp:=pprocsym(p)^.definition;
while assigned(hp) do
begin
if (hp^.options and pomsgstr)<>0 then
begin
new(pt);
pt^.p:=hp;
pt^.l:=nil;
pt^.r:=nil;
insertstr(pt,root);
end;
hp:=hp^.nextoverloaded;
end
else
Begin
{ I assume that both enumerations are equal when the first }
{ pointers are equal. }
if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
Begin
if penumdef(def1)^.first = penumdef(def2)^.first then
is_subequal := TRUE;
end;
end;
end;
end; { endif assigned ... }
end;
procedure writenames(p : pprocdeftree);
begin
getlabel(p^.nl);
if assigned(p^.l) then
writenames(p^.l);
datasegment^.concat(new(pai_label,init(p^.nl)));
datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
if assigned(p^.r) then
writenames(p^.r);
end;
procedure writestrentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writestrentry(p^.l);
{ write name label }
datasegment^.concat(new(pai_const_symbol,init(lab2str(p^.nl))));
datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
if assigned(p^.r) then
writestrentry(p^.r);
end;
function genstrmsgtab(_class : pobjectdef) : plabel;
var
r : plabel;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class^.publicsyms^.foreach(insertmsgstr);
{ write all names }
if assigned(root) then
writenames(root);
{ now start writing of the message string table }
getlabel(r);
datasegment^.concat(new(pai_label,init(r)));
genstrmsgtab:=r;
datasegment^.concat(new(pai_const,init_32bit(count)));
if assigned(root) then
begin
writestrentry(root);
disposeprocdeftree(root);
end;
end;
procedure insertint(p : pprocdeftree;var at : pprocdeftree);
var
i : longint;
begin
if at=nil then
begin
at:=p;
inc(count);
end
else
begin
i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
if p^.p^.messageinf.i<at^.p^.messageinf.i then
insertstr(p,at^.l)
else if p^.p^.messageinf.i>at^.p^.messageinf.i then
insertstr(p,at^.r)
else
Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
end;
end;
procedure writeintentry(p : pprocdeftree);
begin
if assigned(p^.l) then
writeintentry(p^.l);
{ write name label }
datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
maybe_concat_external(p^.p^.owner,p^.p^.mangledname);
if assigned(p^.r) then
writeintentry(p^.r);
end;
procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}
var
hp : pprocdef;
pt : pprocdeftree;
begin
if p^.typ=procsym then
begin
hp:=pprocsym(p)^.definition;
while assigned(hp) do
begin
if (hp^.options and pomsgint)<>0 then
begin
new(pt);
pt^.p:=hp;
pt^.l:=nil;
pt^.r:=nil;
insertint(pt,root);
end;
hp:=hp^.nextoverloaded;
end;
end;
end;
function genintmsgtab(_class : pobjectdef) : plabel;
var
r : plabel;
begin
root:=nil;
count:=0;
{ insert all message handlers into a tree, sorted by name }
_class^.publicsyms^.foreach(insertmsgint);
{ now start writing of the message string table }
getlabel(r);
datasegment^.concat(new(pai_label,init(r)));
genintmsgtab:=r;
datasegment^.concat(new(pai_const,init_32bit(count)));
if assigned(root) then
begin
writeintentry(root);
disposeprocdeftree(root);
end;
end;
type
pprocdefcoll = ^tprocdefcoll;
tprocdefcoll = record
next : pprocdefcoll;
data : pprocdef;
end;
psymcoll = ^tsymcoll;
tsymcoll = record
next : psymcoll;
name : pstring;
data : pprocdefcoll;
end;
var
wurzel : psymcoll;
nextvirtnumber : longint;
_c : pobjectdef;
has_constructor,has_virtual_method : boolean;
procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}
var
procdefcoll : pprocdefcoll;
hp : pprocdef;
symcoll : psymcoll;
_name : string;
stored : boolean;
{ creates a new entry in the procsym list }
procedure newentry;
begin
{ if not, generate a new symbol item }
new(symcoll);
symcoll^.name:=stringdup(sym^.name);
symcoll^.next:=wurzel;
symcoll^.data:=nil;
wurzel:=symcoll;
hp:=pprocsym(sym)^.definition;
{ inserts all definitions }
while assigned(hp) do
begin
new(procdefcoll);
procdefcoll^.data:=hp;
procdefcoll^.next:=symcoll^.data;
symcoll^.data:=procdefcoll;
{ if it's a virtual method }
if (hp^.options and povirtualmethod)<>0 then
begin
{ then it gets a number ... }
hp^.extnumber:=nextvirtnumber;
{ and we inc the number }
inc(nextvirtnumber);
has_virtual_method:=true;
end;
if (hp^.options and poconstructor)<>0 then
has_constructor:=true;
{ check, if a method should be overridden }
if (hp^.options and pooverridingmethod)<>0 then
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
{ next overloaded method }
hp:=hp^.nextoverloaded;
end;
end;
begin
{ put only sub routines into the VMT }
if sym^.typ=procsym then
begin
_name:=sym^.name;
symcoll:=wurzel;
while assigned(symcoll) do
begin
{ does the symbol already exist in the list ? }
if _name=symcoll^.name^ then
begin
{ walk through all defs of the symbol }
hp:=pprocsym(sym)^.definition;
while assigned(hp) do
begin
{ compare with all stored definitions }
procdefcoll:=symcoll^.data;
stored:=false;
while assigned(procdefcoll) do
begin
{ compare parameters }
if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
(
((procdefcoll^.data^.options and povirtualmethod)<>0) or
((hp^.options and povirtualmethod)<>0)
) then
begin
{ wenn sie gleich sind }
{ und eine davon virtual deklariert ist }
{ Fehler falls nur eine VIRTUAL }
if (procdefcoll^.data^.options and povirtualmethod)<>
(hp^.options and povirtualmethod) then
begin
{ in classes, we hide the old method }
if _c^.isclass then
begin
{ warn only if it is the first time,
we hide the method }
if _c=hp^._class then
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
newentry;
exit;
end
else
if _c=hp^._class then
begin
if (procdefcoll^.data^.options and povirtualmethod)<>0 then
Message1(parser_w_overloaded_are_not_both_virtual,_c^.name^+'.'+_name)
else
Message1(parser_w_overloaded_are_not_both_non_virtual,
_c^.name^+'.'+_name);
newentry;
exit;
end;
end;
{ check, if the overridden directive is set }
{ (povirtualmethod is set! }
{ class ? }
if _c^.isclass and
((hp^.options and pooverridingmethod)=0) then
begin
{ warn only if it is the first time,
we hide the method }
if _c=hp^._class then
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
newentry;
exit;
end;
{ error, if the return types aren't equal }
if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) and
not((procdefcoll^.data^.retdef^.deftype=objectdef) and
(hp^.retdef^.deftype=objectdef) and
(pobjectdef(procdefcoll^.data^.retdef)^.isclass) and
(pobjectdef(hp^.retdef)^.isclass) and
(pobjectdef(hp^.retdef)^.isrelated(pobjectdef(procdefcoll^.data^.retdef)))) then
Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
{ the flags have to match }
{ except abstract and override }
if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
(hp^.options and not(poabstractmethod or pooverridingmethod)) then
Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
{ now set the number }
hp^.extnumber:=procdefcoll^.data^.extnumber;
{ and exchange }
procdefcoll^.data:=hp;
stored:=true;
end;
procdefcoll:=procdefcoll^.next;
end;
{ if it isn't saved in the list }
{ we create a new entry }
if not(stored) then
begin
new(procdefcoll);
procdefcoll^.data:=hp;
procdefcoll^.next:=symcoll^.data;
symcoll^.data:=procdefcoll;
{ if the method is virtual ... }
if (hp^.options and povirtualmethod)<>0 then
begin
{ ... it will get a number }
hp^.extnumber:=nextvirtnumber;
inc(nextvirtnumber);
end;
{ check, if a method should be overridden }
if (hp^.options and pooverridingmethod)<>0 then
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
end;
hp:=hp^.nextoverloaded;
end;
exit;
end;
symcoll:=symcoll^.next;
end;
newentry;
end;
end;
procedure genvmt(_class : pobjectdef);
procedure do_genvmt(p : pobjectdef);
begin
{ start with the base class }
if assigned(p^.childof) then
do_genvmt(p^.childof);
{ walk through all public syms }
_c:=_class;
{$ifdef tp}
p^.publicsyms^.foreach(eachsym);
{$else}
p^.publicsyms^.foreach(@eachsym);
{$endif}
end;
var
symcoll : psymcoll;
procdefcoll : pprocdefcoll;
i : longint;
begin
wurzel:=nil;
nextvirtnumber:=0;
has_constructor:=false;
has_virtual_method:=false;
{ generates a tree of all used methods }
do_genvmt(_class);
if has_virtual_method and not(has_constructor) then
Message1(parser_w_virtual_without_constructor,_class^.name^);
{ generates the VMT }
{ walk trough all numbers for virtual methods and search }
{ the method }
for i:=0 to nextvirtnumber-1 do
begin
symcoll:=wurzel;
{ walk trough all symbols }
while assigned(symcoll) do
begin
{ walk trough all methods }
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
{ writes the addresses to the VMT }
{ but only this which are declared as virtual }
if procdefcoll^.data^.extnumber=i then
begin
if (procdefcoll^.data^.options and povirtualmethod)<>0 then
begin
{ if a method is abstract, then is also the }
{ class abstract and it's not allow to }
{ generates an instance }
if (procdefcoll^.data^.options and poabstractmethod)<>0 then
begin
_class^.options:=_class^.options or oo_is_abstract;
datasegment^.concat(new(pai_const_symbol,
init('FPC_ABSTRACTERROR')));
end
else
begin
datasegment^.concat(new(pai_const_symbol,
init(procdefcoll^.data^.mangledname)));
maybe_concat_external(procdefcoll^.data^.owner,
procdefcoll^.data^.mangledname);
end;
end;
end;
procdefcoll:=procdefcoll^.next;
end;
symcoll:=symcoll^.next;
end;
end;
{ disposes the above generated tree }
symcoll:=wurzel;
while assigned(symcoll) do
begin
wurzel:=symcoll^.next;
stringdispose(symcoll^.name);
procdefcoll:=symcoll^.data;
while assigned(procdefcoll) do
begin
symcoll^.data:=procdefcoll^.next;
dispose(procdefcoll);
procdefcoll:=symcoll^.data;
end;
dispose(symcoll);
symcoll:=wurzel;
end;
end;
end.
{
$Log$
Revision 1.55 1999-03-09 11:45:42 pierre
Revision 1.56 1999-03-24 23:17:42 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.55 1999/03/09 11:45:42 pierre
* small arrays and records (size <=4) are copied directly
Revision 1.54 1999/03/02 22:52:20 peter

26
compiler/verbose.pas
View File

@ -70,6 +70,9 @@ procedure UpdateReplacement(var s:string);
procedure Stop;
procedure ShowStatus;
function ErrorCount:longint;
procedure SetMaxErrorCount(count:longint);
procedure GenerateError;
procedure Internalerror(i:longint);
procedure Comment(l:longint;s:string);
procedure Message(w:tmsgconst);
@ -290,6 +293,24 @@ begin
end;
function ErrorCount:longint;
begin
ErrorCount:=status.errorcount;
end;
procedure SetMaxErrorCount(count:longint);
begin
status.maxerrorcount:=count;
end;
procedure GenerateError;
begin
inc(status.errorcount);
end;
procedure internalerror(i : longint);
begin
UpdateStatus;
@ -438,7 +459,10 @@ end.
{
$Log$
Revision 1.35 1999-02-09 17:15:53 florian
Revision 1.36 1999-03-24 23:17:44 peter
* fixed bugs 212,222,225,227,229,231,233
Revision 1.35 1999/02/09 17:15:53 florian
* some false warnings "function result doesn't seems to be set" are
avoided