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

* better position info with UseTokenInfo

Browse Source 
UseTokenInfo greatly simplified
  + added check for changed tree after first time firstpass
    (if we could remove all the cases were it happen
    we could skip all firstpass if firstpasscount > 1)
    Only with ExtDebug
This commit is contained in:
pierre 1998-05-06 08:38:32 +00:00
parent a5c52b5362
commit 6fc80b783f
14 changed files with 697 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
compiler/ag386int.pas
View File

@ -594,9 +594,13 @@ ait_stab_function_name : ;
AsmLn;
AsmWriteLn('SECTION .data');
{$ifdef EXTDEBUG}
AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
if not comp_unit then
{$endif EXTDEBUG}
begin
DataSegment^.insert(new(pai_align,init(4)));
DataSegment^.insert(new(pai_string,init('target: '+target_info.short_name)));
DataSegment^.insert(new(pai_string,init('compiled by FPC '+version_string)));
end;
WriteTree(datasegment);
WriteTree(consts);
WriteTree(rttilist);
@ -624,9 +628,13 @@ ait_stab_function_name : ;
AsmLn;
AsmWriteLn('_DATA'#9#9'SEGMENT'#9'PARA PUBLIC USE32 ''DATA''');
{$ifdef EXTDEBUG}
AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
if not comp_unit then
{$endif EXTDEBUG}
begin
DataSegment^.insert(new(pai_align,init(4)));
DataSegment^.insert(new(pai_string,init('target: '+target_info.short_name)));
DataSegment^.insert(new(pai_string,init('compiled by FPC '+version_string)));
end;
WriteTree(datasegment);
WriteTree(consts);
WriteTree(rttilist);
@ -649,7 +657,15 @@ ait_stab_function_name : ;
end.
{
$Log$
Revision 1.6 1998-05-04 17:54:24 peter
Revision 1.7 1998-05-06 08:38:32 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.6 1998/05/04 17:54:24 peter
+ smartlinking works (only case jumptable left todo)
* redesign of systems.pas to support assemblers and linkers
+ Unitname is now also in the PPU-file, increased version to 14

26
compiler/aopt386.inc
View File

@ -829,8 +829,12 @@ Begin
Inc(NrOfInstrSinceLastMod[TmpReg]);
Case p^.typ Of
ait_label: DestroyAllRegs(p);
ait_labeled_instruction, ait_stabs, ait_stabn,
ait_stab_function_name:; {nothing changes}
ait_labeled_instruction
{$ifdef GDB}
, ait_stabs, ait_stabn,
ait_stab_function_name
{$endif GDB}
:; {nothing changes}
{$ifdef regalloc}
ait_regalloc, ait_regdealloc:;
{$endif regalloc}
@ -1035,7 +1039,13 @@ Begin
hp2 := p;
For Cnt2 := 1 to Cnt Do
Begin
If Not(Pai(p)^.typ In [ait_stabs, ait_stabn, ait_stab_function_name]) Then
{ Note to Jonas :
ait_stab_function_name is only at the begin of one function
ait_stabn is only inserted in ag so you should not see any
ait_stabs are only in head and tail of procs
so you should no have problems with those neither !! (PM)
Tell me if I am wrong
If Not(Pai(p)^.typ In [ait_stabs, ait_stabn, ait_stab_function_name]) Then }
Begin
If (hp1 = nil) And
Not(RegInInstruction(Tregister(Pai386(hp2)^.op2), p))
@ -1191,7 +1201,15 @@ End;
{
$Log$
Revision 1.5 1998-04-29 10:33:42 pierre
Revision 1.6 1998-05-06 08:38:33 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.5 1998/04/29 10:33:42 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output

15
compiler/aopt386.pas
View File

@ -42,7 +42,10 @@ Unit aopt386;
{ait_* types which don't result in executable code or which don't
influence the way the program runs/behaves}
Const SkipInstr = [ait_comment,ait_stabs, ait_stabn, ait_stab_function_name
Const SkipInstr = [ait_comment
{$ifdef GDB}
,ait_stabs, ait_stabn, ait_stab_function_name
{$endif GDB}
{$ifdef regalloc}
,ait_regalloc, ait_regdealloc
{$endif regalloc}
@ -1615,7 +1618,15 @@ end;
End.
{
$Log$
Revision 1.8 1998-04-29 10:33:43 pierre
Revision 1.9 1998-05-06 08:38:34 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.8 1998/04/29 10:33:43 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output

36
compiler/cgi386.pas
View File

@ -224,8 +224,8 @@ implementation
{ first handle local and temporary variables }
if (symtabletype=parasymtable) or
{$ifdef TestInline}
(symtabletype=inlinelocalsymtable) then
(symtabletype=inlineparasymtable) then
(symtabletype=inlinelocalsymtable) or
(symtabletype=inlineparasymtable) or
{$endif TestInline}
(symtabletype=localsymtable) then
begin
@ -3195,8 +3195,8 @@ implementation
((p^.symtableproc^.symtabletype=objectsymtable) and
(pobjectdef(p^.symtableproc^.defowner)^.owner^.symtabletype=unitsymtable)))
else { inlined proc }
{ inlined code is in p^.right }
secondpass(p^.right);
{ inlined code is in inlinecode }
secondpass(inlinecode);
if ((p^.procdefinition^.options and poclearstack)<>0) then
begin
{ consider the alignment with the rest (PM) }
@ -5266,6 +5266,8 @@ do_jmp:
{ true, if we can omit the range check of the jump table }
jumptable_no_range : boolean;
{ where to put the jump table }
jumpsegment : paasmoutput;
procedure gentreejmp(p : pcaserecord);
@ -5420,10 +5422,10 @@ do_jmp:
genitem(t^.less);
{ fill possible hole }
for i:=last+1 to t^._low-1 do
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(elselabel)))));
for i:=t^._low to t^._high do
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(t^.statement)))));
last:=t^._high;
if assigned(t^.greater) then
@ -5462,9 +5464,9 @@ do_jmp:
exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr)));
{ !!!!! generate tables
if not(cs_littlesize in aktswitches^ ) then
datasegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
jumpsegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
}
datasegment^.concat(new(pai_label,init(table)));
jumpsegment^.concat(new(pai_label,init(table)));
last:=min_;
genitem(hp);
{ !!!!!!!
@ -5480,6 +5482,10 @@ do_jmp:
begin
getlabel(endlabel);
getlabel(elselabel);
if smartlink then
jumpsegment:=procinfo.aktlocaldata
else
jumpsegment:=datasegment;
with_sign:=is_signed(p^.left^.resulttype);
if with_sign then
begin
@ -6017,6 +6023,10 @@ do_jmp:
end;
do_secondpass(p);
{$ifdef StoreFPULevel}
if assigned(aktprocsym) then
aktprocsym^.fpu_used:=p^.registersfpu;
{$endif StoreFPULevel}
{ all registers can be used again }
usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
{$ifdef SUPPORT_MMX}
@ -6033,7 +6043,15 @@ do_jmp:
end.
{
$Log$
Revision 1.20 1998-05-01 16:38:44 florian
Revision 1.21 1998-05-06 08:38:36 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.20 1998/05/01 16:38:44 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp

12
compiler/cobjects.pas
View File

@ -143,7 +143,7 @@ unit cobjects;
{ gets a string }
function get : string;
{$ifdef UseTokenInfo}
function get_with_tokeninfo(var file_info : tfileposinfo) : string;
function get_with_tokeninfo(var file_info : tfileposinfo) : string;
{$endif UseTokenInfo}
{ deletes all strings }
@ -1063,7 +1063,15 @@ end;
end.
{
$Log$
Revision 1.5 1998-04-30 15:59:40 pierre
Revision 1.6 1998-05-06 08:38:37 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.5 1998/04/30 15:59:40 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position

14
compiler/hcodegen.pas
View File

@ -88,7 +88,9 @@ unit hcodegen;
exported : boolean;
{ code for the current procedure }
aktproccode,aktentrycode,aktexitcode : paasmoutput;
aktproccode,aktentrycode,
aktexitcode,aktlocaldata : paasmoutput;
{ local data is used for smartlink }
end;
var
@ -355,7 +357,15 @@ end.
{
$Log$
Revision 1.2 1998-04-29 10:33:53 pierre
Revision 1.3 1998-05-06 08:38:40 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.2 1998/04/29 10:33:53 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output

25
compiler/parser.pas
View File

@ -120,12 +120,12 @@ unit parser;
procedure compile(const filename:string;compile_system:boolean);
var
hp : pmodule;
comp_unit : boolean;
old_comp_unit : boolean;
{ some variables to save the compiler state }
oldtoken : ttoken;
{$ifdef UseTokenInfo}
oldtokeninfo : ptokeninfo;
oldtokenpos : tfileposinfo;
{$endif UseTokenInfo}
oldpattern : stringid;
@ -222,6 +222,7 @@ unit parser;
oldrefsymtable:=refsymtable;
refsymtable:=nil;
oldprocprefix:=procprefix;
old_comp_unit:=comp_unit;
{ a long time, this was only in init_parser
but it should be reset to zero for each module }
@ -239,7 +240,7 @@ unit parser;
oldpattern:=pattern;
oldtoken:=token;
{$ifdef UseTokenInfo}
oldtokeninfo:=tokeninfo;
oldtokenpos:=tokenpos;
{$endif UseTokenInfo}
oldorgpattern:=orgpattern;
old_block_type:=block_type;
@ -289,12 +290,7 @@ unit parser;
define_macros;
{ startup scanner }
{$ifndef UseTokenInfo}
token:=yylex;
{$else UseTokenInfo}
tokeninfo:=yylex;
token:=tokeninfo^.token;
{$endif UseTokenInfo}
reset_gdb_info;
{ init asm writing }
@ -482,10 +478,11 @@ done:
pattern:=oldpattern;
token:=oldtoken;
{$ifdef UseTokenInfo}
tokeninfo:=oldtokeninfo;
tokenpos:=oldtokenpos;
{$endif UseTokenInfo}
orgpattern:=oldorgpattern;
block_type:=old_block_type;
comp_unit:=old_comp_unit;
{ call donescanner before restoring preprocstack, because }
{ donescanner tests for a empty preprocstack }
@ -537,7 +534,15 @@ done:
end.
{
$Log$
Revision 1.12 1998-05-04 17:54:28 peter
Revision 1.13 1998-05-06 08:38:42 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.12 1998/05/04 17:54:28 peter
+ smartlinking works (only case jumptable left todo)
* redesign of systems.pas to support assemblers and linkers
+ Unitname is now also in the PPU-file, increased version to 14

132
compiler/pass_1.pas
View File

@ -614,7 +614,7 @@ unit pass_1;
exit;
{ overloaded operator ? }
if (p^.treetype=caretn) or
if (p^.treetype=starstarn) or
(ld^.deftype=recorddef) or
{ <> and = are defined for classes }
((ld^.deftype=objectdef) and
@ -731,6 +731,7 @@ unit pass_1;
Message(sym_e_type_mismatch);
end;
disposetree(p);
firstpass(t);
p:=t;
exit;
end
@ -879,6 +880,7 @@ unit pass_1;
dispose(s2);
{$endif UseAnsiString}
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
@ -1287,6 +1289,11 @@ unit pass_1;
exit;
{ determines result type for comparions }
{ here the is a problem with multiple passes }
{ example length(s)+1 gets internal 'longint' type first }
{ if it is a arg it is converted to 'LONGINT' }
{ but a second first pass will reset this to 'longint' }
if not assigned(p^.resulttype) then
case p^.treetype of
ltn,lten,gtn,gten,equaln,unequaln:
begin
@ -1336,6 +1343,7 @@ unit pass_1;
divn : t:=genordinalconstnode(p^.left^.value div p^.right^.value,s32bitdef);
end;
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
@ -1378,6 +1386,7 @@ unit pass_1;
shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef);
end;
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
@ -1660,6 +1669,7 @@ unit pass_1;
begin
t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
disposetree(p);
firstpass(t);
p:=t;
exit;
end;
@ -1929,23 +1939,24 @@ unit pass_1;
exit;
{ determine return type }
if p^.left^.resulttype^.deftype=arraydef then
p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
else if (p^.left^.resulttype^.deftype=pointerdef) then
begin
{ convert pointer to array }
harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
p^.left:=gentypeconvnode(p^.left,harr);
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=parraydef(harr)^.definition
end
else
{ indexed access to arrays }
p^.resulttype:=cchardef;
if not assigned(p^.resulttype) then
if p^.left^.resulttype^.deftype=arraydef then
p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
else if (p^.left^.resulttype^.deftype=pointerdef) then
begin
{ convert pointer to array }
harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
p^.left:=gentypeconvnode(p^.left,harr);
firstpass(p^.left);
if codegenerror then
exit;
p^.resulttype:=parraydef(harr)^.definition
end
else
{ indexed access to arrays }
p^.resulttype:=cchardef;
{ the register calculation is easy if a const index is used }
if p^.right^.treetype=ordconstn then
@ -2048,6 +2059,9 @@ unit pass_1;
{ convert constants direct }
{ not because of type conversion }
t:=genrealconstnode(p^.left^.value);
{ do a first pass here
because firstpass of typeconv does
not redo it for left field !! }
firstpass(t);
{ the type can be something else than s64real !!}
t:=gentypeconvnode(t,p^.resulttype);
@ -2175,12 +2189,11 @@ unit pass_1;
{ Florian I think this is overestimated
but I still do not really understand how to get this right (PM) }
{ Hmmm, I think we need only one reg to return the result of }
{ this node => so
{ this node => so }
if p^.registers32<1 then
p^.registers32:=1;
should work (FK)
}
p^.registers32:=p^.left^.registers32+1;
{ should work (FK)
p^.registers32:=p^.left^.registers32+1;}
end;
procedure first_proc_to_procvar(var p : ptree);
@ -2425,6 +2438,7 @@ unit pass_1;
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
@ -2444,6 +2458,7 @@ unit pass_1;
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end
@ -2461,6 +2476,7 @@ unit pass_1;
if p^.left^.treetype=ordconstn then
begin
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
firstpass(hp);
disposetree(p);
p:=hp;
exit;
@ -2504,6 +2520,7 @@ unit pass_1;
testrange(p^.resulttype,p^.left^.value);
hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
disposetree(p);
firstpass(hp);
p:=hp;
exit;
end;
@ -2534,7 +2551,10 @@ unit pass_1;
end;
if defcoll=nil then
begin
if not(assigned(p^.resulttype)) then
{ this breaks typeconversions in write !!! (PM) }
{if not(assigned(p^.resulttype)) then }
if not(assigned(p^.resulttype)) or
(p^.left^.treetype=typeconvn) then
firstpass(p^.left)
else
exit;
@ -2691,6 +2711,9 @@ unit pass_1;
must_be_valid:=false;
{ procedure variable ? }
{ right contains inline code for inlined procedures }
if (not assigned(p^.procdefinition)) or
((p^.procdefinition^.options and poinline)=0) then
if assigned(p^.right) then
begin
{ procedure does a call }
@ -3131,14 +3154,17 @@ unit pass_1;
begin
if assigned(p^.methodpointer) then
comment(v_fatal,'Unable to inline object methods');
if assigned(p^.right) then
if assigned(p^.right) and (p^.right^.treetype<>procinlinen) then
comment(v_fatal,'Unable to inline procvar calls');
{ p^.treetype:=procinlinen; }
if assigned(p^.procdefinition^.code) then
p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
else
comment(v_fatal,'no code for inline procedure stored');
firstpass(p^.right);
if not assigned(p^.right) then
begin
if assigned(p^.procdefinition^.code) then
p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
else
comment(v_fatal,'no code for inline procedure stored');
firstpass(p^.right);
end;
end
else
procinfo.flags:=procinfo.flags or pi_do_call;
@ -3204,6 +3230,10 @@ unit pass_1;
end;
end;
{$ifdef StoreFPULevel}
{ a fpu can be used in any procedure !! }
p^.registersfpu:=p^.procdefinition^.fpu_used;
{$endif StoreFPULevel}
{ if this is a call to a method calc the registers }
if (p^.methodpointer<>nil) then
begin
@ -3307,6 +3337,7 @@ unit pass_1;
else
v:=porddef(Adef)^.bis;
hp:=genordinalconstnode(v,adef);
firstpass(hp);
disposetree(p);
p:=hp;
end;
@ -4777,6 +4808,11 @@ unit pass_1;
{ there some calls of do_firstpass in the parser }
oldis : pinputfile;
oldnr : longint;
{$ifdef extdebug}
str1,str2 : string;
oldp : ptree;
not_first : boolean;
{$endif extdebug}
begin
{ if we save there the whole stuff, }
@ -4786,7 +4822,16 @@ unit pass_1;
oldcodegenerror:=codegenerror;
oldswitches:=aktswitches;
{$ifdef extdebug}
inc(p^.firstpasscount);
if p^.firstpasscount>0 then
begin
move(p^,str1[1],sizeof(ttree));
str1[0]:=char(sizeof(ttree));
new(oldp);
oldp^:=p^;
not_first:=true;
end
else
not_first:=false;
{$endif extdebug}
codegenerror:=false;
@ -4802,6 +4847,23 @@ unit pass_1;
codegenerror:=codegenerror or oldcodegenerror;
end
else codegenerror:=true;
{$ifdef extdebug}
if not_first then
begin
{ dirty trick to compare two ttree's (PM) }
move(p^,str2[1],sizeof(ttree));
str2[0]:=char(sizeof(ttree));
if str1<>str2 then
begin
comment(v_debug,'tree changed after first counting pass '
+tostr(longint(p^.treetype)));
compare_trees(p,oldp);
end;
dispose(oldp);
end;
if count_ref then
inc(p^.firstpasscount);
{$endif extdebug}
aktswitches:=oldswitches;
current_module^.current_inputfile:=oldis;
current_module^.current_inputfile^.line_no:=oldnr;
@ -4829,7 +4891,15 @@ unit pass_1;
end.
{
$Log$
Revision 1.16 1998-05-01 16:38:45 florian
Revision 1.17 1998-05-06 08:38:43 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.16 1998/05/01 16:38:45 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp

52
compiler/pbase.pas
View File

@ -45,9 +45,6 @@ unit pbase;
var
{ contains the current token to be processes }
token : ttoken;
{$ifdef UseTokenInfo}
tokeninfo : ptokeninfo;
{$endif UseTokenInfo}
{ size of data segment, set by proc_unit or proc_program }
datasize : longint;
@ -89,6 +86,10 @@ unit pbase;
{ sc is disposed }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
{ just for an accurate position of the end of a procedure (PM) }
var
last_endtoken_filepos: tfileposinfo;
implementation
@ -124,7 +125,6 @@ unit pbase;
j : integer;
begin
{$ifndef UseTokenInfo}
if token<>i then
begin
if i<_AND then
@ -143,33 +143,15 @@ unit pbase;
end;
end
else
token:=yylex;
begin
if token=_END then
{$ifdef UseTokenInfo}
last_endtoken_filepos:=tokenpos;
{$else UseTokenInfo}
if token<>i then
begin
if i<_AND then
syntaxerror(tokens[i])
else
begin
{ um die ProgrammgrӇe klein zu halten, }
{ wird f<>r ein Schl<68>sselwort-Token der }
{ "Text" in der Schl<68>sselworttabelle }
{ des Scanners nachgeschaut }
for j:=1 to anz_keywords do
if keyword_token[j]=i then
syntaxerror(keyword[j])
end;
end
else
begin
if assigned(tokeninfo) then
dispose(tokeninfo);
tokeninfo:=yylex;
token:=tokeninfo^.token;
end;
get_cur_file_pos(last_endtoken_filepos);
{$endif UseTokenInfo}
token:=yylex;
end;
end;
procedure consume_all_until(atoken : ttoken);
@ -212,7 +194,7 @@ unit pbase;
sc^.insert(pattern);
{$else UseTokenInfo}
sc^.insert_with_tokeninfo(pattern,
tokeninfo^.fi);
tokenpos);
{$endif UseTokenInfo}
consume(ID);
if token=COMMA then consume(COMMA)
@ -268,7 +250,15 @@ end.
{
$Log$
Revision 1.4 1998-04-30 15:59:41 pierre
Revision 1.5 1998-05-06 08:38:44 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.4 1998/04/30 15:59:41 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position

64
compiler/pexpr.pas
View File

@ -655,12 +655,32 @@ unit pexpr;
d : bestreal;
constset : pconstset;
propsym : ppropertysym;
{$ifdef UseTokenInfo}
oldp1 : ptree;
filepos : tfileposinfo;
{$endif UseTokenInfo}
{$ifdef UseTokenInfo}
procedure check_tokenpos;
begin
if (p1<>oldp1) then
begin
if assigned(p1) then
set_tree_filepos(p1,filepos);
oldp1:=p1;
filepos:=tokenpos;
end;
end;
{$endif UseTokenInfo}
{ p1 and p2 must contain valid values }
procedure postfixoperators;
begin
{$ifdef UseTokenInfo}
check_tokenpos;
{$endif UseTokenInfo}
while again do
begin
case token of
@ -885,6 +905,9 @@ unit pexpr;
else again:=false;
end;
end;
{$ifdef UseTokenInfo}
check_tokenpos;
{$endif UseTokenInfo}
end;
end;
@ -910,6 +933,10 @@ unit pexpr;
actprocsym : pprocsym;
begin
{$ifdef UseTokenInfo}
oldp1:=nil;
filepos:=tokenpos;
{$endif UseTokenInfo}
case token of
ID:
begin
@ -1492,6 +1519,9 @@ unit pexpr;
end;
end;
factor:=p1;
{$ifdef UseTokenInfo}
check_tokenpos;
{$endif UseTokenInfo}
end;
type Toperator_precedence=(opcompare,opaddition,opmultiply);
@ -1529,6 +1559,10 @@ unit pexpr;
var p1,p2:Ptree;
oldt:Ttoken;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
begin
{ if pred_level=high(Toperator_precedence) then }
@ -1543,6 +1577,10 @@ unit pexpr;
((token<>EQUAL) or accept_equal) then
begin
oldt:=token;
{$ifdef UseTokenInfo}
filepos:=tokenpos;
{$endif UseTokenInfo}
consume(token);
{ if pred_level=high(Toperator_precedence) then }
if pred_level=opmultiply then
@ -1550,6 +1588,10 @@ unit pexpr;
else
p2:=sub_expr(succ(pred_level),true);
p1:=gennode(tok2node[oldt],p1,p2);
{$ifdef UseTokenInfo}
set_tree_filepos(p1,filepos);
{$endif UseTokenInfo}
end
else
break;
@ -1574,12 +1616,20 @@ unit pexpr;
var
p1,p2 : ptree;
oldafterassignment : boolean;
{$ifdef UseTokenInfo}
oldp1 : ptree;
filepos : tfileposinfo;
{$endif UseTokenInfo}
begin
oldafterassignment:=afterassignment;
p1:=sub_expr(opcompare,true);
if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true;
{$ifdef UseTokenInfo}
filepos:=tokenpos;
oldp1:=p1;
{$endif UseTokenInfo}
case token of
POINTPOINT : begin
consume(POINTPOINT);
@ -1632,6 +1682,10 @@ unit pexpr;
end;
end;
afterassignment:=oldafterassignment;
{$ifdef UseTokenInfo}
if p1<>oldp1 then
set_tree_filepos(p1,filepos);
{$endif UseTokenInfo}
expr:=p1;
end;
@ -1681,7 +1735,15 @@ unit pexpr;
end.
{
$Log$
Revision 1.12 1998-05-05 12:05:42 florian
Revision 1.13 1998-05-06 08:38:45 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.12 1998/05/05 12:05:42 florian
* problems with properties fixed
* crash fixed: i:=l when i and l are undefined, was a problem with
implementation of private/protected

51
compiler/pstatmnt.pas
View File

@ -61,6 +61,9 @@ unit pstatmnt;
{ read assembler tokens }
,pbase,pexpr,pdecl;
const
statement_level : longint = 0;
function statement : ptree;forward;
@ -177,6 +180,7 @@ unit pstatmnt;
Message(parser_e_ordinal_expected);
consume(_OF);
inc(statement_level);
wurzel:=nil;
ranges:=false;
instruc:=nil;
@ -242,6 +246,7 @@ unit pstatmnt;
elseblock:=nil;
consume(_END);
end;
dec(statement_level);
code:=gencasenode(caseexpr,instruc,wurzel);
@ -258,6 +263,8 @@ unit pstatmnt;
begin
consume(_REPEAT);
first:=nil;
inc(statement_level);
while token<>_UNTIL do
begin
if first=nil then
@ -277,6 +284,8 @@ unit pstatmnt;
consume(SEMICOLON);
end;
consume(_UNTIL);
dec(statement_level);
first:=gensinglenode(blockn,first);
p_e:=comp_expr(true);
repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
@ -454,6 +463,8 @@ unit pstatmnt;
{ read statements to try }
consume(_TRY);
first:=nil;
inc(statement_level);
while (token<>_FINALLY) and (token<>_EXCEPT) do
begin
if first=nil then
@ -478,6 +489,8 @@ unit pstatmnt;
consume(_FINALLY);
p_finally_block:=statements_til_end;
try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block);
dec(statement_level);
end
else
begin
@ -519,6 +532,8 @@ unit pstatmnt;
begin
p_default:=statements_til_end;
end;
dec(statement_level);
in_except_block:=old_in_except_block;
try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false);
end;
@ -783,10 +798,18 @@ unit pstatmnt;
var
first,last : ptree;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
begin
first:=nil;
{$ifdef UseTokenInfo}
filepos:=tokenpos;
{$endif UseTokenInfo}
consume(_BEGIN);
inc(statement_level);
while token<>_END do
begin
if first=nil then
@ -816,8 +839,14 @@ unit pstatmnt;
emptystats;
end;
consume(_END);
dec(statement_level);
last:=gensinglenode(blockn,first);
{$ifdef UseTokenInfo}
set_tree_filepos(last,filepos);
{$else UseTokenInfo}
set_file_line(first,last);
{$endif UseTokenInfo}
statement_block:=last;
end;
@ -836,7 +865,7 @@ unit pstatmnt;
begin
{$ifdef UseTokenInfo}
filepos:=tokeninfo^.fi;
filepos:=tokenpos;
{$endif UseTokenInfo}
case token of
_GOTO : begin
@ -993,7 +1022,9 @@ unit pstatmnt;
{ as it is handled differently }
funcretsym^._name:=strpnew('func_result');
{$else TEST_FUNCRET }
procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
{ align func result at 4 byte }
procinfo.retoffset:=
-((-procinfo.firsttemp+(procinfo.retdef^.size+3)) div 4)*4;
procinfo.firsttemp:=procinfo.retoffset;
{$endif TEST_FUNCRET }
if (procinfo.flags and pi_operator)<>0 then
@ -1052,7 +1083,7 @@ unit pstatmnt;
usedinproc:=usedinproc or ($800 shr word(R_D0))
{$endif}
end
else
else if not is_fpu(procinfo.retdef) then
{ should we allow assembler functions of big elements ? }
Message(parser_e_asm_incomp_with_function_return);
end;
@ -1068,8 +1099,8 @@ unit pstatmnt;
procinfo.framepointer:=R_SP;
{$endif}
{ set the right value for parameters }
dec(aktprocsym^.definition^.parast^.call_offset,4);
dec(procinfo.call_offset,4);
dec(aktprocsym^.definition^.parast^.call_offset,sizeof(pointer));
dec(procinfo.call_offset,sizeof(pointer));
end;
assembler_block:=_asm_statement;
end;
@ -1077,7 +1108,15 @@ unit pstatmnt;
end.
{
$Log$
Revision 1.8 1998-05-05 12:05:42 florian
Revision 1.9 1998-05-06 08:38:46 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.8 1998/05/05 12:05:42 florian
* problems with properties fixed
* crash fixed: i:=l when i and l are undefined, was a problem with
implementation of private/protected

170
compiler/scanner.pas
View File

@ -161,21 +161,18 @@ unit scanner;
{$ifdef UseTokenInfo}
type
{ type
ttokeninfo = record
token : ttoken;
fi : tfileposinfo;
end;
ptokeninfo = ^ttokeninfo;
ptokeninfo = ^ttokeninfo; }
var tokenpos : tfileposinfo;
{$endif UseTokenInfo}
{public}
procedure syntaxerror(const s : string);
{$ifndef UseTokenInfo}
function yylex : ttoken;
{$else UseTokenInfo}
function yylex : ptokeninfo;
{$endif UseTokenInfo}
function asmgetchar : char;
function get_current_col : longint;
procedure get_cur_file_pos(var fileinfo : tfileposinfo);
@ -667,16 +664,11 @@ unit scanner;
end;
{$ifndef UseTokenInfo}
function yylex : ttoken;
{$else UseTokenInfo}
function yylex : ptokeninfo;
{$endif UseTokenInfo}
var
y : ttoken;
{$ifdef UseTokenInfo}
newyylex : ptokeninfo;
line,column : longint;
fileindex,line,column : longint;
{$endif UseTokenInfo}
code : word;
l : longint;
@ -691,6 +683,7 @@ unit scanner;
{$ifdef UseTokenInfo}
line:=current_module^.current_inputfile^.line_no;
column:=get_current_col;
fileindex:=current_module^.current_index;
{$endif UseTokenInfo}
{ was the last character a point ? }
{ this code is needed because the scanner if there is a 1. found if }
@ -708,10 +701,10 @@ unit scanner;
yylex:=POINT;
exit;
{$else UseTokenInfo}
y:=POINTPOINT;
yylex:=POINTPOINT;
goto exit_label;
end;
y:=POINT;
yylex:=POINT;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -729,6 +722,7 @@ unit scanner;
{$ifdef UseTokenInfo}
line:=current_module^.current_inputfile^.line_no;
column:=get_current_col;
fileindex:=current_module^.current_index;
{ will become line:=lasttokenpos ??;}
{$endif UseTokenInfo}
case c of
@ -737,9 +731,7 @@ unit scanner;
orgpattern:=readstring;
pattern:=upper(orgpattern);
if (length(pattern) in [2..id_len]) and is_keyword(y) then
{$ifndef UseTokenInfo}
yylex:=y
{$endif UseTokenInfo}
else
begin
{ this takes some time ... }
@ -786,33 +778,29 @@ unit scanner;
exit;
end;
end;
{$ifndef UseTokenInfo}
yylex:=ID;
end;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=ID;
end;
goto exit_label;
{$endif UseTokenInfo}
end;
'$' : begin
pattern:=readnumber;
{$ifndef UseTokenInfo}
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=INTCONST;
goto exit_label;
{$endif UseTokenInfo}
end;
'%' : begin
pattern:=readnumber;
{$ifndef UseTokenInfo}
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=INTCONST;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -824,11 +812,10 @@ unit scanner;
if not(c in ['0'..'9']) then
begin
s_point:=true;
{$ifndef UseTokenInfo}
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=INTCONST;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -838,11 +825,10 @@ unit scanner;
pattern:=pattern+c;
readchar;
end;
{$ifndef UseTokenInfo}
yylex:=REALNUMBER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=REALNUMBER;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -861,50 +847,45 @@ unit scanner;
pattern:=pattern+c;
readchar;
end;
{$ifndef UseTokenInfo}
yylex:=REALNUMBER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=REALNUMBER;
goto exit_label;
{$endif UseTokenInfo}
end;
end;
{$ifndef UseTokenInfo}
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=INTCONST;
goto exit_label;
{$endif UseTokenInfo}
end;
';' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=SEMICOLON;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=SEMICOLON;
goto exit_label;
{$endif UseTokenInfo}
end;
'[' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=LECKKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=LECKKLAMMER;
goto exit_label;
{$endif UseTokenInfo}
end;
']' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=RECKKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=RECKKLAMMER;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -920,21 +901,19 @@ unit scanner;
{$endif TP}
exit;
end;
{$ifndef UseTokenInfo}
yylex:=LKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=LKLAMMER;
goto exit_label;
{$endif UseTokenInfo}
end;
')' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=RKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=RKLAMMER;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -943,19 +922,17 @@ unit scanner;
if (c='=') and c_like_operators then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_PLUSASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_PLUSASN;
goto exit_label;
{$endif UseTokenInfo}
end;
{$ifndef UseTokenInfo}
yylex:=PLUS;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=PLUS;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -964,19 +941,17 @@ unit scanner;
if (c='=') and c_like_operators then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_MINUSASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_MINUSASN;
goto exit_label;
{$endif UseTokenInfo}
end;
{$ifndef UseTokenInfo}
yylex:=MINUS;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=MINUS;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -985,19 +960,17 @@ unit scanner;
if c='=' then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=ASSIGNMENT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=ASSIGNMENT;
goto exit_label;
{$endif UseTokenInfo}
end;
{$ifndef UseTokenInfo}
yylex:=COLON;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=COLON;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1006,26 +979,17 @@ unit scanner;
if (c='=') and c_like_operators then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_STARASN;
{$else UseTokenInfo}
y:=_STARASN;
{$endif UseTokenInfo}
end else if c='*' then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=STARSTAR;
{$else UseTokenInfo}
y:=STARSTAR;
{$endif UseTokenInfo}
end
else
{$ifndef UseTokenInfo}
yylex:=STAR;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=STAR;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1036,11 +1000,10 @@ unit scanner;
if c_like_operators then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_SLASHASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_SLASHASN;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1055,21 +1018,19 @@ unit scanner;
exit;
end;
end;
{$ifndef UseTokenInfo}
yylex:=SLASH;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=SLASH;
goto exit_label;
{$endif UseTokenInfo}
end;
'=' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=EQUAL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=EQUAL;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1078,20 +1039,18 @@ unit scanner;
if c='.' then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=POINTPOINT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=POINTPOINT;
goto exit_label;
{$endif UseTokenInfo}
end
else
{$ifndef UseTokenInfo}
yylex:=POINT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=POINT;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1100,28 +1059,22 @@ unit scanner;
if c='@' then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=DOUBLEADDR;
{$else UseTokenInfo}
y:=DOUBLEADDR;
{$endif UseTokenInfo}
end
else
{$ifndef UseTokenInfo}
yylex:=KLAMMERAFFE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=KLAMMERAFFE;
goto exit_label;
{$endif UseTokenInfo}
end;
',' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=COMMA;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=COMMA;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1138,11 +1091,10 @@ unit scanner;
end
else
begin
{$ifndef UseTokenInfo}
yylex:=CARET;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=CARET;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1187,17 +1139,13 @@ unit scanner;
end;
until false;
{ strings with length 1 become const chars }
{$ifndef UseTokenInfo}
if length(pattern)=1 then
yylex:=CCHAR
else
yylex:=CSTRING;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
if length(pattern)=1 then
y:=CCHAR
else
y:=CSTRING;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1206,40 +1154,36 @@ unit scanner;
case c of
'=' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=GTE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=GTE;
goto exit_label;
{$endif UseTokenInfo}
end;
'>' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_SHR;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_SHR;
goto exit_label;
{$endif UseTokenInfo}
end;
'<' : begin { >< is for a symetric diff for sets }
readchar;
{$ifndef UseTokenInfo}
yylex:=SYMDIF;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=SYMDIF;
goto exit_label;
{$endif UseTokenInfo}
end;
end;
{$ifndef UseTokenInfo}
yylex:=GT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=GT;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1248,49 +1192,44 @@ unit scanner;
case c of
'>' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=UNEQUAL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=UNEQUAL;
goto exit_label;
{$endif UseTokenInfo}
end;
'=' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=LTE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=LTE;
goto exit_label;
{$endif UseTokenInfo}
end;
'<' : begin
readchar;
{$ifndef UseTokenInfo}
yylex:=_SHL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_SHL;
goto exit_label;
{$endif UseTokenInfo}
end;
end;
{$ifndef UseTokenInfo}
yylex:=LT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=LT;
goto exit_label;
{$endif UseTokenInfo}
end;
#26 : begin
{$ifndef UseTokenInfo}
yylex:=_EOF;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
y:=_EOF;
goto exit_label;
{$endif UseTokenInfo}
end;
@ -1301,12 +1240,9 @@ unit scanner;
end;
{$ifdef UseTokenInfo}
exit_label:
new(newyylex);
newyylex^.token:=y;
newyylex^.fi.fileindex:=current_module^.current_index;
newyylex^.fi.line:=line;
newyylex^.fi.column:=column;
yylex:=newyylex;
tokenpos.fileindex:=fileindex;
tokenpos.line:=line;
tokenpos.column:=column;
{$endif UseTokenInfo}
end;
@ -1461,7 +1397,15 @@ unit scanner;
end.
{
$Log$
Revision 1.16 1998-05-04 17:54:28 peter
Revision 1.17 1998-05-06 08:38:47 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.16 1998/05/04 17:54:28 peter
+ smartlinking works (only case jumptable left todo)
* redesign of systems.pas to support assemblers and linkers
+ Unitname is now also in the PPU-file, increased version to 14

13
compiler/systems.pas
View File

@ -45,6 +45,9 @@ unit systems;
{$ifdef i386}
,link_ldgo32v1, link_ldgo32v2, link_ldw, link_ldos2);
{$endif i386}
{$ifdef m68k}
);
{$endif}
tendian = (endian_little,en_big_endian);
@ -516,7 +519,15 @@ begin
end.
{
$Log$
Revision 1.8 1998-05-04 20:19:54 peter
Revision 1.9 1998-05-06 08:38:49 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.8 1998/05/04 20:19:54 peter
* small fix for go32v2
Revision 1.7 1998/05/04 17:54:29 peter

287
compiler/tree.pas
View File

@ -46,6 +46,7 @@ unit tree;
pconstset = ^tconstset;
ttreetyp = (addn, {Represents the + operator.}
muln, {Represents the * operator.}
subn, {Represents the - operator.}
@ -284,8 +285,8 @@ unit tree;
procedure set_file_line(from,_to : ptree);
procedure set_current_file_line(_to : ptree);
procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
{$ifdef extdebug}
procedure compare_trees(p1,p2 : ptree);
const
maxfirstpasscount : longint = 0;
{$endif extdebug}
@ -295,7 +296,13 @@ unit tree;
implementation
{$ifdef UseTokenInfo}
uses pbase;
{$ifdef extdebug}
uses
types,pbase;
{$else extdebug}
uses
pbase;
{$endif extdebug}
{$endif UseTokenInfo}
{****************************************************************************
@ -349,13 +356,10 @@ unit tree;
{ we know also the position }
{$ifdef UseTokenInfo}
if assigned(tokeninfo) then
begin
hp^.fileinfo:=tokeninfo^.fi;
end
else
hp^.fileinfo:=tokenpos;
{$else UseTokenInfo}
get_cur_file_pos(hp^.fileinfo);
{$endif UseTokenInfo}
get_cur_file_pos(hp^.fileinfo);
hp^.pragmas:=aktswitches;
getnode:=hp;
end;
@ -1167,6 +1171,263 @@ unit tree;
gensetconstruktnode:=p;
end;
{$ifdef extdebug}
procedure compare_trees(p1,p2 : ptree);
var
error_found : boolean;
begin
if p1^.error<>p2^.error then
begin
comment(v_warning,'error field different');
error_found:=true;
end;
if p1^.disposetyp<>p2^.disposetyp then
begin
comment(v_warning,'disposetyp field different');
error_found:=true;
end;
{ is true, if the right and left operand are swaped }
if p1^.swaped<>p2^.swaped then
begin
comment(v_warning,'swaped field different');
error_found:=true;
end;
{ the location of the result of this node }
if p1^.location.loc<>p2^.location.loc then
begin
comment(v_warning,'location.loc field different');
error_found:=true;
end;
{ the number of registers needed to evalute the node }
if p1^.registers32<>p2^.registers32 then
begin
comment(v_warning,'registers32 field different');
comment(v_warning,tostr(p1^.registers32)+'<>'+tostr(p2^.registers32));
error_found:=true;
end;
if p1^.registersfpu<>p2^.registersfpu then
begin
comment(v_warning,'registersfpu field different');
error_found:=true;
end;
{$ifdef SUPPORT_MMX}
if p1^.registersmmx<>p2^.registersmmx then
begin
comment(v_warning,'registersmmx field different');
error_found:=true;
end;
{$endif SUPPORT_MMX}
if p1^.left<>p2^.left then
begin
comment(v_warning,'left field different');
error_found:=true;
end;
if p1^.right<>p2^.right then
begin
comment(v_warning,'right field different');
error_found:=true;
end;
if p1^.resulttype<>p2^.resulttype then
begin
error_found:=true;
if is_equal(p1^.resulttype,p2^.resulttype) then
comment(v_debug,'resulttype fields are different but equal')
else
comment(v_warning,'resulttype fields are really different');
end;
if p1^.fileinfo.line<>p2^.fileinfo.line then
begin
comment(v_warning,'fileinfo.line field different');
error_found:=true;
end;
if p1^.fileinfo.column<>p2^.fileinfo.column then
begin
comment(v_warning,'fileinfo.column field different');
error_found:=true;
end;
if p1^.fileinfo.fileindex<>p2^.fileinfo.fileindex then
begin
comment(v_warning,'fileinfo.fileindex field different');
error_found:=true;
end;
if p1^.pragmas<>p2^.pragmas then
begin
comment(v_warning,'pragmas field different');
error_found:=true;
end;
{$ifdef extdebug}
if p1^.firstpasscount<>p2^.firstpasscount then
begin
comment(v_warning,'firstpasscount field different');
error_found:=true;
end;
{$endif extdebug}
if p1^.treetype=p2^.treetype then
case p1^.treetype of
addn :
begin
if p1^.use_strconcat<>p2^.use_strconcat then
begin
comment(v_warning,'use_strconcat field different');
error_found:=true;
end;
if p1^.string_typ<>p2^.string_typ then
begin
comment(v_warning,'stringtyp field different');
error_found:=true;
end;
end;
callparan :
{(is_colon_para : boolean;exact_match_found : boolean);}
begin
if p1^.is_colon_para<>p2^.is_colon_para then
begin
comment(v_warning,'use_strconcat field different');
error_found:=true;
end;
if p1^.exact_match_found<>p2^.exact_match_found then
begin
comment(v_warning,'exact_match_found field different');
error_found:=true;
end;
end;
assignn :
{(assigntyp : tassigntyp;concat_string : boolean);}
begin
if p1^.assigntyp<>p2^.assigntyp then
begin
comment(v_warning,'assigntyp field different');
error_found:=true;
end;
if p1^.concat_string<>p2^.concat_string then
begin
comment(v_warning,'concat_string field different');
error_found:=true;
end;
end;
loadn :
{(symtableentry : psym;symtable : psymtable;
is_absolute,is_first : boolean);}
begin
if p1^.symtableentry<>p2^.symtableentry then
begin
comment(v_warning,'symtableentry field different');
error_found:=true;
end;
if p1^.symtable<>p2^.symtable then
begin
comment(v_warning,'symtable field different');
error_found:=true;
end;
if p1^.is_absolute<>p2^.is_absolute then
begin
comment(v_warning,'is_absolute field different');
error_found:=true;
end;
if p1^.is_first<>p2^.is_first then
begin
comment(v_warning,'is_first field different');
error_found:=true;
end;
end;
calln :
{(symtableprocentry : pprocsym;
symtableproc : psymtable;procdefinition : pprocdef;
methodpointer : ptree;
no_check,unit_specific : boolean);}
begin
if p1^.symtableprocentry<>p2^.symtableprocentry then
begin
comment(v_warning,'symtableprocentry field different');
error_found:=true;
end;
if p1^.symtableproc<>p2^.symtableproc then
begin
comment(v_warning,'symtableproc field different');
error_found:=true;
end;
if p1^.procdefinition<>p2^.procdefinition then
begin
comment(v_warning,'procdefinition field different');
error_found:=true;
end;
if p1^.methodpointer<>p2^.methodpointer then
begin
comment(v_warning,'methodpointer field different');
error_found:=true;
end;
if p1^.no_check<>p2^.no_check then
begin
comment(v_warning,'no_check field different');
error_found:=true;
end;
if p1^.unit_specific<>p2^.unit_specific then
begin
error_found:=true;
comment(v_warning,'unit_specific field different');
end;
end;
ordconstn :
begin
if p1^.value<>p2^.value then
begin
comment(v_warning,'value field different');
error_found:=true;
end;
end;
realconstn :
begin
if p1^.valued<>p2^.valued then
begin
comment(v_warning,'valued field different');
error_found:=true;
end;
if p1^.labnumber<>p2^.labnumber then
begin
comment(v_warning,'labnumber field different');
error_found:=true;
end;
if p1^.realtyp<>p2^.realtyp then
begin
comment(v_warning,'realtyp field different');
error_found:=true;
end;
end;
(*realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint);
{$ifdef TEST_FUNCRET}
funcretn : (funcretprocinfo : pointer;retdef : pdef);
{$endif TEST_FUNCRET}
subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
{ string const can be longer then 255 with ansistring !! }
{$ifdef UseAnsiString}
stringconstn : (values : pchar;length : longint; labstrnumber : longint);
{$else UseAnsiString}
stringconstn : (values : pstring; labstrnumber : longint);
{$endif UseAnsiString}
typeconvn : (convtyp : tconverttype;explizit : boolean);
inlinen : (inlinenumber : longint);
procinlinen : (inlineprocdef : pprocdef);
setconstrn : (constset : pconstset);
loopn : (t1,t2 : ptree;backward : boolean);
asmn : (p_asm : paasmoutput);
casen : (nodes : pcaserecord;elseblock : ptree);
labeln,goton : (labelnr : plabel);
withn : (withsymtable : psymtable;tablecount : longint);
end; *)
end;
if not error_found then
comment(v_warning,'did not find difference in trees');
end;
{$endif extdebug}
function equal_trees(t1,t2 : ptree) : boolean;
begin
@ -1263,7 +1524,15 @@ unit tree;
end.
{
$Log$
Revision 1.5 1998-04-30 15:59:43 pierre
Revision 1.6 1998-05-06 08:38:52 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.5 1998/04/30 15:59:43 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position