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

+ UseTokenInfo now default

Browse Source 
* unit in interface uses and implementation uses gives error now
  * only one error for unknown symbol (uses lastsymknown boolean)
    the problem came from the label code !
  + first inlined procedures and function work
    (warning there might be allowed cases were the result is still wrong !!)
  * UseBrower updated gives a global list of all position of all used symbols
    with switch -gb
This commit is contained in:
pierre 1998-05-20 09:42:32 +00:00
parent a21b12c9e4
commit c80de3be27
21 changed files with 1412 additions and 737 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
compiler/browser.pas
View File

@ -23,24 +23,24 @@ unit browser;
interface
uses globals, files;
uses globals,cobjects,files;
type
pref = ^tref;
tref = object
nextref : pref;
inputfile : pinputfile;
lineno : longint;
constructor init(ref : pref);
constructor load(var ref : pref;fileindex : word;line : longint);
posinfo : tfileposinfo;
moduleindex : word;
constructor init(ref : pref;pos : pfileposinfo);
constructor load(var ref : pref;fileindex : word;line,column : longint);
destructor done; virtual;
function get_file_line : string;
end;
{ simple method to chain all refs }
procedure add_new_ref(var ref : pref);
procedure add_new_ref(var ref : pref;pos : pfileposinfo);
function get_source_file(index : word) : pinputfile;
function get_source_file(moduleindex,fileindex : word) : pinputfile;
{ one big problem remains for overloaded procedure }
{ we should be able to separate them }
@ -48,80 +48,95 @@ type
implementation
constructor tref.init(ref :pref);
uses scanner,verbose;
constructor tref.init(ref :pref;pos : pfileposinfo);
begin
nextref:=nil;
if ref<>nil then
ref^.nextref:=@self;
if assigned(pos) then
posinfo:=pos^;
if current_module<>nil then
begin
inputfile:=current_module^.current_inputfile;
if inputfile<>nil then
begin
inc(inputfile^.ref_index);
lineno:=inputfile^.line_no;
end
else
lineno:=0;
end
else
begin
inputfile:=nil;
lineno:=0;
moduleindex:=current_module^.unit_index;
end;
end;
constructor tref.load(var ref : pref;fileindex : word;line : longint);
constructor tref.load(var ref : pref;fileindex : word;line,column : longint);
begin
moduleindex:=current_module^.unit_index;
if assigned(ref) then
ref^.nextref:=@self;
nextref:=nil;
inputfile:=get_source_file(fileindex);
lineno:=line;
posinfo.fileindex:=fileindex;
posinfo.line:=line;
posinfo.column:=column;
ref:=@self;
end;
destructor tref.done;
var
inputfile : pinputfile;
begin
inputfile:=get_source_file(moduleindex,posinfo.fileindex);
if inputfile<>nil then
dec(inputfile^.ref_count);
end;
function tref.get_file_line : string;
var
inputfile : pinputfile;
begin
get_file_line:='';
if inputfile=nil then exit;
if Use_Rhide then
get_file_line:=lowercase(inputfile^.name^+inputfile^.ext^)+':'+tostr(lineno)+':'
inputfile:=get_source_file(moduleindex,posinfo.fileindex);
if assigned(inputfile) then
if Use_Rhide then
get_file_line:=globals.lowercase(inputfile^.name^+inputfile^.ext^)
+':'+tostr(posinfo.line)+':'+tostr(posinfo.column)+':'
else
get_file_line:=inputfile^.name^+inputfile^.ext^
+'('+tostr(posinfo.line)+','+tostr(posinfo.column)+')'
else
get_file_line:=inputfile^.name^+inputfile^.ext^+'('+tostr(lineno)+')'
if Use_Rhide then
get_file_line:='file_unknown:'
+tostr(posinfo.line)+':'+tostr(posinfo.column)+':'
else
get_file_line:='file_unknown('
+tostr(posinfo.line)+','+tostr(posinfo.column)+')'
end;
procedure add_new_ref(var ref : pref);
procedure add_new_ref(var ref : pref;pos : pfileposinfo);
var
newref : pref;
begin
new(newref,init(ref));
new(newref,init(ref,pos));
ref:=newref;
end;
function get_source_file(index : word) : pinputfile;
function get_source_file(moduleindex,fileindex : word) : pinputfile;
var
hp : pmodule;
f : pinputfile;
begin
hp:=pmodule(loaded_units.first);
while assigned(hp) and (hp^.unit_index<>moduleindex) do
hp:=pmodule(hp^.next);
get_source_file:=nil;
f:=pinputfile(current_module^.sourcefiles.files);
if not assigned(hp) then
exit;
f:=pinputfile(hp^.sourcefiles.files);
while assigned(f) do
begin
if f^.ref_index=index then
if f^.ref_index=fileindex then
begin
get_source_file:=f;
exit;
@ -133,7 +148,17 @@ implementation
end.
{
$Log$
Revision 1.2 1998-04-30 15:59:39 pierre
Revision 1.3 1998-05-20 09:42:32 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.2 1998/04/30 15:59:39 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position

778
compiler/cgi386.pas
View File

File diff suppressed because it is too large Load Diff

84
compiler/cobjects.pas
View File

@ -55,9 +55,7 @@ unit cobjects;
tstringitem = record
data : pstring;
next : pstringitem;
{$ifdef UseTokenInfo}
fileinfo : tfileposinfo; { pointer to tinputfile }
{$endif UseTokenInfo}
end;
plinkedlist_item = ^tlinkedlist_item;
@ -144,15 +142,11 @@ unit cobjects;
{ inserts a string }
procedure insert(const s : string);
{$ifdef UseTokenInfo}
procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo);
{$endif UseTokenInfo}
{ gets a string }
function get : string;
{$ifdef UseTokenInfo}
function get_with_tokeninfo(var file_info : tfileposinfo) : string;
{$endif UseTokenInfo}
{ deletes all strings }
procedure clear;
@ -176,7 +170,11 @@ unit cobjects;
{ but it's assumed, that there no seek while do_crc is true }
do_crc : boolean;
crc : longint;
{ temporary closing feature }
tempclosed : boolean;
tempmode : byte;
temppos : longint;
{ inits a buffer with the size bufsize which is assigned to }
{ the file filename }
constructor init(const filename : string;_bufsize : longint);
@ -216,6 +214,12 @@ unit cobjects;
{ closes the file and releases the buffer }
procedure close;
{$ifdef TEST_TEMPCLOSE}
{ temporary closing }
procedure tempclose;
procedure tempreopen;
{$endif TEST_TEMPCLOSE}
{ goto the given position }
procedure seek(l : longint);
@ -479,7 +483,6 @@ end;
last:=hp;
end;
{$ifdef UseTokenInfo}
procedure tstringcontainer.insert_with_tokeninfo
(const s : string; const file_info : tfileposinfo);
@ -505,7 +508,6 @@ end;
last:=hp;
end;
{$endif UseTokenInfo}
procedure tstringcontainer.clear;
var
@ -542,7 +544,6 @@ end;
end;
end;
{$ifdef UseTokenInfo}
function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string;
var
@ -566,7 +567,6 @@ end;
dispose(hp);
end;
end;
{$endif UseTokenInfo}
{****************************************************************************
TLINKEDLIST_ITEM
@ -807,6 +807,7 @@ end;
buflast:=0;
do_crc:=false;
iomode:=0;
tempclosed:=false;
change_endian:=false;
clear_crc;
end;
@ -994,8 +995,11 @@ end;
begin
if bufpos+length(s)>bufsize then
flush;
{ why is there not CRC here ??? }
move(s[1],(buf+bufpos)^,length(s));
inc(bufpos,length(s));
{ should be
write_data(s[1],length(s)); }
end;
procedure tbufferedfile.write_pchar(p : pchar);
@ -1007,10 +1011,13 @@ end;
l:=strlen(p);
if l>=bufsize then
runerror(222);
{ why is there not CRC here ???}
if bufpos+l>bufsize then
flush;
move(p^,(buf+bufpos)^,l);
inc(bufpos,l);
{ should be
write_data(p^,l); }
end;
procedure tbufferedfile.write_byte(b : byte);
@ -1071,14 +1078,67 @@ end;
flush;
system.close(f);
freemem(buf,bufsize);
buf:=nil;
iomode:=0;
end;
end;
{$ifdef TEST_TEMPCLOSE}
procedure tbufferedfile.tempclose;
begin
if iomode<>0 then
begin
temppos:=system.filepos(f);
tempmode:=iomode;
tempclosed:=true;
system.close(f);
iomode:=0;
end
else
tempclosed:=false;
end;
procedure tbufferedfile.tempreopen;
var
ofm : byte;
begin
if tempclosed then
begin
if tempmode=1 then
begin
ofm:=filemode;
iomode:=1;
filemode:=0;
system.reset(f,1);
filemode:=ofm;
end
else if tempmode=2 then
begin
iomode:=2;
system.rewrite(f,1);
end;
system.seek(f,temppos);
end;
end;
{$endif TEST_TEMPCLOSE}
end.
{
$Log$
Revision 1.7 1998-05-06 18:36:53 peter
Revision 1.8 1998-05-20 09:42:33 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.7 1998/05/06 18:36:53 peter
* tai_section extended with code,data,bss sections and enumerated type
* ident 'compiled by FPC' moved to pmodules
* small fix for smartlink

32
compiler/files.pas
View File

@ -102,6 +102,7 @@ unit files;
map : punitmap; { mapping of all used units }
unitcount : word; { local unit counter }
unit_index : word; { global counter for browser }
symtable : pointer; { pointer to the psymtable of this unit }
output_format : tof; { how to write this file }
@ -219,6 +220,7 @@ unit files;
var
main_module : pmodule;
current_module : pmodule;
global_unit_count : word;
loaded_units : tlinkedlist;
@ -300,11 +302,21 @@ unit files;
dispose(hp,done);
hp:=files;
end;
last_ref_index:=0;
end;
procedure tfilemanager.close_all;
var
hp : pextfile;
begin
hp:=files;
while assigned(hp) do
begin
hp^.close;
hp:=hp^._next;
end;
end;
procedure tfilemanager.register_file(f : pextfile);
@ -420,6 +432,12 @@ unit files;
sources_avail:=false;
temp:=' library';
end
else if pos('Macro ',hs)=1 then
begin
{ we don't want to find this file }
{ but there is a problem with file indexing !! }
temp:='';
end
else
begin
{ check the date of the source files }
@ -849,6 +867,8 @@ unit files;
flags:=0;
crc:=0;
unitcount:=1;
inc(global_unit_count);
unit_index:=global_unit_count;
do_assemble:=false;
do_compile:=false;
sources_avail:=true;
@ -909,7 +929,17 @@ unit files;
end.
{
$Log$
Revision 1.11 1998-05-12 10:46:59 peter
Revision 1.12 1998-05-20 09:42:33 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.11 1998/05/12 10:46:59 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

35
compiler/hcodegen.pas
View File

@ -50,6 +50,8 @@ unit hcodegen;
_class : pobjectdef;
{ return type }
retdef : pdef;
{ the definition of the proc itself }
def : pdef;
{ frame pointer offset }
framepointer_offset : longint;
{ self pointer offset }
@ -140,14 +142,15 @@ unit hcodegen;
{ convert/concats a label for constants in the consts section }
function constlabel2str(p:plabel;ctype:tconsttype):string;
function constlabel2str(l : plabel;ctype:tconsttype):string;
function constlabelnb2str(pnb : longint;ctype:tconsttype):string;
procedure concat_constlabel(p:plabel;ctype:tconsttype);
implementation
uses
cobjects,globals,files,strings;
systems,cobjects,globals,files,strings;
{*****************************************************************************
initialize/terminate the codegen for procedure and modules
@ -353,12 +356,22 @@ implementation
consttypestr : array[tconsttype] of string[6]=
('ord','string','real','bool','int','char','set');
function constlabel2str(p:plabel;ctype:tconsttype):string;
{ Peter this gives problems for my inlines !! }
{ we must use the number directly !!! (PM) }
function constlabel2str(l : plabel;ctype:tconsttype):string;
begin
if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then
constlabel2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(p^.nb)
constlabel2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(l^.nb)
else
constlabel2str:=lab2str(p);
constlabel2str:=lab2str(l);
end;
function constlabelnb2str(pnb : longint;ctype:tconsttype):string;
begin
if smartlink or (current_module^.output_format in [of_nasm,of_obj]) then
constlabelnb2str:='_$'+current_module^.unitname^+'$'+consttypestr[ctype]+'_const_'+tostr(pnb)
else
constlabelnb2str:=target_asm.labelprefix+tostr(pnb);
end;
@ -385,7 +398,17 @@ end.
{
$Log$
Revision 1.4 1998-05-07 00:17:01 peter
Revision 1.5 1998-05-20 09:42:34 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.4 1998/05/07 00:17:01 peter
* smartlinking for sets
+ consts labels are now concated/generated in hcodegen
* moved some cpu code to cga and some none cpu depended code from cga

29
compiler/i386.pas
View File

@ -315,7 +315,8 @@ unit i386;
{ resets all values of ref to defaults }
procedure reset_reference(var ref : treference);
{ mostly set value of a reference }
function new_reference(base : tregister;offset : longint) : preference;
{ same as reset_reference, but symbol is disposed }
{ use this only for already used references }
procedure clear_reference(var ref : treference);
@ -1179,7 +1180,19 @@ unit i386;
{$endif}
end;
procedure clear_reference(var ref : treference);
function new_reference(base : tregister;offset : longint) : preference;
var
r : preference;
begin
new(r);
reset_reference(r^);
r^.base:=base;
r^.offset:=offset;
new_reference:=r;
end;
procedure clear_reference(var ref : treference);
begin
stringdispose(ref.symbol);
@ -1780,7 +1793,17 @@ unit i386;
end.
{
$Log$
Revision 1.6 1998-05-04 17:54:25 peter
Revision 1.7 1998-05-20 09:42:34 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.6 1998/05/04 17:54:25 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

30
compiler/parser.pas
View File

@ -123,9 +123,7 @@ unit parser;
{ some variables to save the compiler state }
oldtoken : ttoken;
{$ifdef UseTokenInfo}
oldtokenpos : tfileposinfo;
{$endif UseTokenInfo}
oldpattern : stringid;
oldpreprocstack : ppreprocstack;
@ -237,9 +235,7 @@ unit parser;
oldmacros:=macros;
oldpattern:=pattern;
oldtoken:=token;
{$ifdef UseTokenInfo}
oldtokenpos:=tokenpos;
{$endif UseTokenInfo}
oldorgpattern:=orgpattern;
old_block_type:=block_type;
oldpreprocstack:=preprocstack;
@ -284,7 +280,7 @@ unit parser;
{ init code generator for a new module }
codegen_newmodule;
macros:=new(psymtable,init(macrosymtable));
macros^.name:=stringdup('Conditionals for '+filename);
define_macros;
{ startup scanner }
@ -306,7 +302,6 @@ unit parser;
{ global switches are read, so further changes aren't allowed }
current_module^.in_main:=true;
{ open assembler response }
if (compile_level=1) then
AsmRes.Init('ppas');
@ -320,6 +315,7 @@ unit parser;
}
hp:=loadunit(upper(target_info.system_unit),true,true);
systemunit:=hp^.symtable;
make_ref:=false;
readconstdefs;
{ we could try to overload caret by default }
symtablestack:=systemunit;
@ -328,6 +324,7 @@ unit parser;
if assigned(srsym) and (srsym^.typ=procsym) and
(overloaded_operators[STARSTAR]=nil) then
overloaded_operators[STARSTAR]:=pprocsym(srsym);
make_ref:=true;
end
else
begin
@ -364,6 +361,7 @@ unit parser;
systemunit:=nil;
end;
registerdef:=true;
make_ref:=true;
{ current return type is void }
procinfo.retdef:=voiddef;
@ -447,16 +445,16 @@ done:
procprefix:=oldprocprefix;
{ close the inputfiles }
{$ifndef UseBrowser}
{ but not if we want the names for the browser ! }
{$ifdef UseBrowser}
{ we need the names for the browser ! }
current_module^.sourcefiles.close_all;
{$else UseBrowser}
current_module^.sourcefiles.done;
{$endif not UseBrowser}
{ restore scanner state }
pattern:=oldpattern;
token:=oldtoken;
{$ifdef UseTokenInfo}
tokenpos:=oldtokenpos;
{$endif UseTokenInfo}
orgpattern:=oldorgpattern;
block_type:=old_block_type;
@ -508,7 +506,17 @@ done:
end.
{
$Log$
Revision 1.16 1998-05-12 10:47:00 peter
Revision 1.17 1998-05-20 09:42:34 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.16 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

178
compiler/pass_1.pas
View File

@ -35,7 +35,7 @@ unit pass_1;
implementation
uses
cobjects,verbose,systems,globals,aasm,symtable,
scanner,cobjects,verbose,systems,globals,aasm,symtable,
types,strings,hcodegen,files
{$ifdef i386}
,i386
@ -125,16 +125,20 @@ unit pass_1;
end;
{ calculates the needed registers for a binary operator }
procedure calcregisters(p : ptree;r32,fpu,mmx : word);
procedure left_right_max(p : ptree);
begin
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
end;
{ calculates the needed registers for a binary operator }
procedure calcregisters(p : ptree;r32,fpu,mmx : word);
begin
left_right_max(p);
{ Nur wenn links und rechts ein Unterschied < ben”tige Anzahl ist, }
{ wird ein zus„tzliches Register ben”tigt, da es dann keinen }
{ schwierigeren Ast gibt, welcher erst ausgewertet werden kann }
@ -164,7 +168,8 @@ unit pass_1;
end;
function isconvertable(def_from,def_to : pdef;
var doconv : tconverttype;fromtreetype : ttreetyp) : boolean;
var doconv : tconverttype;fromtreetype : ttreetyp;
explicit : boolean) : boolean;
{ from_is_cstring muá true sein, wenn def_from die Definition einer }
{ Stringkonstanten ist, n”tig wegen der Konvertierung von String- }
@ -260,7 +265,9 @@ unit pass_1;
doconv:=tc_real_2_real;
{ comp isn't a floating type }
{$ifdef i386}
if (pfloatdef(def_to)^.typ=s64bit) then
if (pfloatdef(def_to)^.typ=s64bit) and
(pfloatdef(def_from)^.typ<>s64bit) and
not (explicit) then
Message(parser_w_convert_real_2_comp);
{$endif}
end;
@ -1356,13 +1363,7 @@ unit pass_1;
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
if p^.registers32<2 then p^.registers32:=2;
left_right_max(p);
p^.resulttype:=s32bitdef;
p^.location.loc:=LOC_REGISTER;
end;
@ -1887,7 +1888,7 @@ unit pass_1;
Message(cg_e_upper_lower_than_lower);
{ both types must be compatible }
if not(isconvertable(p^.left^.resulttype,p^.right^.resulttype,
ct,ordconstn)) and
ct,ordconstn,false)) and
not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) then
Message(sym_e_type_mismatch);
end;
@ -1910,7 +1911,7 @@ unit pass_1;
begin
if not(isconvertable(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef,
ct,ordconstn)) and
ct,ordconstn,false)) and
not(is_equal(p^.right^.resulttype,
parraydef(p^.left^.resulttype)^.rangedef)) then
Message(sym_e_type_mismatch);
@ -2306,7 +2307,8 @@ unit pass_1;
p^.registersmmx:=p^.left^.registersmmx;
{$endif}
set_location(p^.location,p^.left^.location);
if (not(isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype))) then
if (not(isconvertable(p^.left^.resulttype,p^.resulttype,
p^.convtyp,p^.left^.treetype,p^.explizit))) then
begin
if is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
begin
@ -2431,7 +2433,8 @@ unit pass_1;
end
else
begin
if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn { nur Dummy} ) then
if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,
ordconstn { nur Dummy},false ) then
Message(cg_e_illegal_type_conversion);
end;
@ -2451,7 +2454,8 @@ unit pass_1;
end
else
begin
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,
ordconstn { nur Dummy},false ) then
Message(cg_e_illegal_type_conversion);
end;
end
@ -2472,7 +2476,8 @@ unit pass_1;
begin
{ this is wrong because it converts to a 4 byte long var !!
if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then }
if not isconvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
if not isconvertable(p^.left^.resulttype,u8bitdef,
p^.convtyp,ordconstn { nur Dummy},false ) then
Message(cg_e_illegal_type_conversion);
end;
end
@ -2567,7 +2572,8 @@ unit pass_1;
must_be_valid:=false;
{ here we must add something for the implicit type }
{ conversion from array of char to pchar }
if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then
if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,
p^.left^.treetype,false) then
if convtyp=tc_array_to_pointer then
must_be_valid:=false;
firstpass(p^.left);
@ -2657,10 +2663,11 @@ unit pass_1;
pd : pprocdef;
actprocsym : pprocsym;
def_from,def_to,conv_to : pdef;
pt : ptree;
exactmatch : boolean;
pt,inlinecode : ptree;
exactmatch,inlined : boolean;
paralength,l : longint;
pdc : pdefcoll;
curtokenpos : tfileposinfo;
{ only Dummy }
hcvt : tconverttype;
@ -2696,10 +2703,19 @@ unit pass_1;
store_valid:=must_be_valid;
must_be_valid:=false;
inlined:=false;
if assigned(p^.procdefinition) and
((p^.procdefinition^.options and poinline)<>0) then
begin
inlinecode:=p^.right;
if assigned(inlinecode) then
begin
inlined:=true;
p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline);
end;
p^.right:=nil;
end;
{ 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 }
@ -2887,7 +2903,8 @@ unit pass_1;
begin
{ erst am Anfang }
while (assigned(procs)) and
not(isconvertable(pt^.resulttype,procs^.nextpara^.data,hcvt,pt^.left^.treetype)) do
not(isconvertable(pt^.resulttype,procs^.nextpara^.data,
hcvt,pt^.left^.treetype,false)) do
begin
hp:=procs^.next;
dispose(procs);
@ -2898,7 +2915,7 @@ unit pass_1;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data,
hcvt,pt^.left^.treetype)) then
hcvt,pt^.left^.treetype,false)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
@ -3077,7 +3094,11 @@ unit pass_1;
end;
{$endif CHAINPROCSYMS}
{$ifdef UseBrowser}
add_new_ref(procs^.data^.lastref);
if make_ref then
begin
get_cur_file_pos(curtokenpos);
add_new_ref(procs^.data^.lastref,@curtokenpos);
end;
{$endif UseBrowser}
p^.procdefinition:=procs^.data;
@ -3100,14 +3121,6 @@ unit pass_1;
{$endif CHAINPROCSYMS}
end;{ end of procedure to call determination }
{ work trough all parameters to insert the type conversions }
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=true;
firstcallparan(p^.left,p^.procdefinition^.para1);
count_ref:=old_count_ref;
end;
{ handle predefined procedures }
if (p^.procdefinition^.options and pointernproc)<>0 then
begin
@ -3135,6 +3148,7 @@ unit pass_1;
end
else
{ no intern procedure => we do a call }
{ calc the correture value for the register }
{ handle predefined procedures }
if (p^.procdefinition^.options and poinline)<>0 then
begin
@ -3146,16 +3160,32 @@ unit pass_1;
if not assigned(p^.right) then
begin
if assigned(p^.procdefinition^.code) then
p^.right:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
inlinecode:=genprocinlinenode(p,ptree(p^.procdefinition^.code))
else
comment(v_fatal,'no code for inline procedure stored');
firstpass(p^.right);
if assigned(inlinecode) then
begin
firstpass(inlinecode);
{ consider it has not inlined if called
again inside the args }
p^.procdefinition^.options:=p^.procdefinition^.options and (not poinline);
inlined:=true;
end;
end;
end
else
procinfo.flags:=procinfo.flags or pi_do_call;
{ calc the correture value for the register }
{ work trough all parameters to insert the type conversions }
{ !!! done now after internproc !! (PM) }
if assigned(p^.left) then
begin
old_count_ref:=count_ref;
count_ref:=true;
firstcallparan(p^.left,p^.procdefinition^.para1);
count_ref:=old_count_ref;
end;
{$ifdef i386}
for regi:=R_EAX to R_EDI do
begin
@ -3246,6 +3276,11 @@ unit pass_1;
end;
end;
if inlined then
begin
p^.right:=inlinecode;
p^.procdefinition^.options:=p^.procdefinition^.options or poinline;
end;
{ determine the registers of the procedure variable }
{ is this OK for inlined procs also ?? (PM) }
if assigned(p^.right) then
@ -3301,7 +3336,7 @@ unit pass_1;
var
hp,hpp : ptree;
isreal,store_valid,file_is_typed : boolean;
store_count_ref,isreal,store_valid,file_is_typed : boolean;
procedure do_lowhigh(adef : pdef);
@ -3336,9 +3371,16 @@ unit pass_1;
end;
begin
store_valid:=must_be_valid;
store_count_ref:=count_ref;
count_ref:=false;
{ if we handle writeln; p^.left contains no valid address }
if assigned(p^.left) then
begin
if p^.left^.treetype=callparan then
firstcallparan(p^.left,nil)
else
firstpass(p^.left);
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
@ -3346,7 +3388,6 @@ unit pass_1;
{$endif SUPPORT_MMX}
set_location(p^.location,p^.left^.location);
end;
store_valid:=must_be_valid;
if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x,
in_typeof_x,in_ord_x,
in_reset_typedfile,in_rewrite_typedfile]) then
@ -3492,9 +3533,8 @@ unit pass_1;
(penumdef(p^.resulttype)^.has_jumps) then
begin
Message(parser_e_succ_and_pred_enums_with_assign_not_possible);
exit;
end;
if p^.left^.treetype=ordconstn then
end
else if p^.left^.treetype=ordconstn then
begin
if p^.inlinenumber=in_pred_x then
hp:=genordinalconstnode(p^.left^.value+1,
@ -3840,6 +3880,7 @@ unit pass_1;
else internalerror(8);
end;
must_be_valid:=store_valid;
count_ref:=store_count_ref;
end;
procedure firstsubscriptn(var p : ptree);
@ -4021,11 +4062,7 @@ unit pass_1;
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
left_right_max(p);
{ this is not allways true due to optimization }
{ but if we don't set this we get problems with optimizing self code }
if psetdef(p^.right^.resulttype)^.settype<>smallset then
@ -4053,6 +4090,7 @@ unit pass_1;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.right^.registersmmx;
{$endif SUPPORT_MMX}
{ left is the next in the list }
firstpass(p^.left);
if codegenerror then
exit;
@ -4534,11 +4572,7 @@ unit pass_1;
if codegenerror then
exit;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
left_right_max(p);
{ left must be a class }
if (p^.left^.resulttype^.deftype<>objectdef) or
@ -4567,11 +4601,13 @@ unit pass_1;
if codegenerror then
exit;
left_right_max(p);
(* this was wrong,no ??
p^.registersfpu:=max(p^.left^.registersfpu,p^.left^.registersfpu);
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
{$endif SUPPORT_MMX}
{$endif SUPPORT_MMX} *)
{ left must be a class }
if (p^.left^.resulttype^.deftype<>objectdef) or
@ -4626,14 +4662,7 @@ unit pass_1;
firstpass(p^.right);
p^.right:=gentypeconvnode(p^.right,s32bitdef);
firstpass(p^.right);
p^.registersfpu:=max(p^.left^.registersfpu,
p^.right^.registersfpu);
p^.registers32:=max(p^.left^.registers32,
p^.right^.registers32);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,
p^.right^.registersmmx);
{$endif SUPPORT_MMX}
left_right_max(p);
end;
end;
end;
@ -4652,14 +4681,7 @@ unit pass_1;
if codegenerror then
exit;
p^.registers32:=max(p^.left^.registers32,
p^.right^.registers32);
p^.registersfpu:=max(p^.left^.registersfpu,
p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
p^.registersmmx:=max(p^.left^.registersmmx,
p^.right^.registersmmx);
{$endif SUPPORT_MMX}
left_right_max(p);
p^.resulttype:=voiddef;
end
else
@ -4838,7 +4860,7 @@ unit pass_1;
begin
comment(v_debug,'tree changed after first counting pass '
+tostr(longint(p^.treetype)));
compare_trees(p,oldp);
compare_trees(oldp,p);
end;
dispose(oldp);
end;
@ -4872,7 +4894,17 @@ unit pass_1;
end.
{
$Log$
Revision 1.18 1998-05-11 13:07:55 peter
Revision 1.19 1998-05-20 09:42:34 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.18 1998/05/11 13:07:55 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments

44
compiler/pbase.pas
View File

@ -94,7 +94,7 @@ unit pbase;
uses
files,scanner,symtable,systems,verbose;
files,scanner,systems,verbose;
{ consumes token i, if the current token is unequal i }
{ a syntax error is written }
@ -148,11 +148,7 @@ unit pbase;
else
begin
if token=_END then
{$ifdef UseTokenInfo}
last_endtoken_filepos:=tokenpos;
{$else UseTokenInfo}
get_cur_file_pos(last_endtoken_filepos);
{$endif UseTokenInfo}
token:=yylex;
end;
end;
@ -160,19 +156,11 @@ unit pbase;
procedure consume_all_until(atoken : ttoken);
begin
{$ifndef UseTokenInfo}
while (token<>atoken) and (token<>_EOF) do
consume(token);
{ this will create an error if the token is _EOF }
if token<>atoken then
consume(atoken);
{$else UseTokenInfo}
while (token<>atoken) and (token<>_EOF) do
consume(token);
{ this will create an error if the token is _EOF }
if token<>atoken then
consume(atoken);
{$endif UseTokenInfo}
{ this error is fatal as we have read the whole file }
Message(scan_f_end_of_file);
end;
@ -193,12 +181,8 @@ unit pbase;
begin
sc:=new(pstringcontainer,init);
repeat
{$ifndef UseTokenInfo}
sc^.insert(pattern);
{$else UseTokenInfo}
sc^.insert_with_tokeninfo(pattern,
tokenpos);
{$endif UseTokenInfo}
consume(ID);
if token=COMMA then consume(COMMA)
else break
@ -212,27 +196,17 @@ unit pbase;
var
s : string;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
ss : pvarsym;
{$endif UseTokenInfo}
begin
{$ifdef UseTokenInfo}
s:=sc^.get_with_tokeninfo(filepos);
{$else UseTokenInfo}
s:=sc^.get;
{$endif UseTokenInfo}
while s<>'' do
begin
{$ifndef UseTokenInfo}
st^.insert(new(pvarsym,init(s,def)));
{$else UseTokenInfo}
ss:=new(pvarsym,init(s,def));
ss^.line_no:=filepos.line;
st^.insert(ss);
{$endif UseTokenInfo}
{ static data fields are inserted in the globalsymtable }
if (st^.symtabletype=objectsymtable) and
((current_object_option and sp_static)<>0) then
@ -240,11 +214,7 @@ unit pbase;
s:=lowercase(st^.name^)+'_'+s;
st^.defowner^.owner^.insert(new(pvarsym,init(s,def)));
end;
{$ifdef UseTokenInfo}
s:=sc^.get_with_tokeninfo(filepos);
{$else UseTokenInfo}
s:=sc^.get;
{$endif UseTokenInfo}
end;
dispose(sc,done);
end;
@ -253,7 +223,17 @@ end.
{
$Log$
Revision 1.6 1998-05-12 10:47:00 peter
Revision 1.7 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.6 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

40
compiler/pdecl.pas
View File

@ -201,7 +201,7 @@ unit pdecl;
{$ifndef GDB}
else d:=new(pstringdef,init(255));
{$else GDB}
else d:=globaldef('SYSTEM.STRING');
else d:=globaldef('STRING');
{$endif GDB}
{$else UseAnsiString}
if p^.value>255 then
@ -211,18 +211,18 @@ unit pdecl;
{$ifndef GDB}
else d:=new(pstringdef,init(255));
{$else GDB}
else d:=globaldef('SYSTEM.STRING');
else d:=globaldef('STRING');
{$endif GDB}
consume(RECKKLAMMER);
{$endif UseAnsiString}
disposetree(p);
end
{ should string bwithout suffix be an ansistring also
{ should string without suffix be an ansistring also
in ansistring mode ?? (PM) }
{$ifndef GDB}
else d:=new(pstringdef,init(255));
{$else GDB}
else d:=globaldef('SYSTEM.STRING');
else d:=globaldef('STRING');
{$endif GDB}
stringtype:=d;
end;
@ -382,9 +382,7 @@ unit pdecl;
sc : pstringcontainer;
hp : pdef;
s : string;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
pp : pprocdef;
begin
@ -442,7 +440,7 @@ unit pdecl;
end
else
hp:=new(pformaldef,init);
s:=sc^.get;
s:=sc^.get_with_tokeninfo(filepos);
while s<>'' do
begin
new(hp2);
@ -450,7 +448,7 @@ unit pdecl;
hp2^.data:=hp;
hp2^.next:=propertyparas;
propertyparas:=hp2;
s:=sc^.get;
s:=sc^.get_with_tokeninfo(filepos);
end;
dispose(sc,done);
if token=SEMICOLON then consume(SEMICOLON)
@ -1546,9 +1544,7 @@ unit pdecl;
old_block_type : tblock_type;
{ to handle absolute }
abssym : pabsolutesym;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
begin
@ -1566,11 +1562,7 @@ unit pdecl;
p:=read_type('');
if do_absolute and (token=ID) and (pattern='ABSOLUTE') then
begin
{$ifdef UseTokenInfo}
s:=sc^.get_with_tokeninfo(filepos);
{$else UseTokenInfo}
s:=sc^.get;
{$endif UseTokenInfo}
s:=sc^.get_with_tokeninfo(filepos);
if sc^.get<>'' then
Message(parser_e_absolute_only_one_var);
dispose(sc,done);
@ -1586,9 +1578,7 @@ unit pdecl;
abssym^.typ:=absolutesym;
abssym^.abstyp:=tovar;
abssym^.ref:=srsym;
{$ifdef UseTokenInfo}
abssym^.line_no:=filepos.line;
{$endif UseTokenInfo}
symtablestack^.insert(abssym);
end
else
@ -1600,9 +1590,7 @@ unit pdecl;
abssym^.typ:=absolutesym;
abssym^.abstyp:=toasm;
abssym^.asmname:=stringdup(s);
{$ifdef UseTokenInfo}
abssym^.line_no:=filepos.line;
{$endif UseTokenInfo}
symtablestack^.insert(abssym);
end
else
@ -1615,9 +1603,7 @@ unit pdecl;
abssym^.typ:=absolutesym;
abssym^.abstyp:=toaddr;
abssym^.absseg:=false;
{$ifdef UseTokenInfo}
abssym^.line_no:=filepos.line;
{$endif UseTokenInfo}
s:=pattern;
consume(INTCONST);
val(s,abssym^.address,code);
@ -1787,7 +1773,17 @@ unit pdecl;
end.
{
$Log$
Revision 1.17 1998-05-11 13:07:55 peter
Revision 1.18 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.17 1998/05/11 13:07:55 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments

45
compiler/pexpr.pas
View File

@ -654,13 +654,10 @@ 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
@ -671,15 +668,12 @@ unit pexpr;
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
@ -904,9 +898,7 @@ unit pexpr;
else again:=false;
end;
end;
{$ifdef UseTokenInfo}
check_tokenpos;
{$endif UseTokenInfo}
end;
end;
@ -930,10 +922,8 @@ unit pexpr;
possible_error : boolean;
begin
{$ifdef UseTokenInfo}
oldp1:=nil;
filepos:=tokenpos;
{$endif UseTokenInfo}
case token of
ID:
begin
@ -954,7 +944,14 @@ unit pexpr;
end
else
begin
getsym(pattern,true);
if lastsymknown then
begin
srsym:=lastsrsym;
srsymtable:=lastsrsymtable;
lastsymknown:=false;
end
else
getsym(pattern,true);
consume(ID);
{ is this an access to a function result ? }
if assigned(aktprocsym) and
@ -1516,9 +1513,7 @@ unit pexpr;
end;
end;
factor:=p1;
{$ifdef UseTokenInfo}
check_tokenpos;
{$endif UseTokenInfo}
end;
type Toperator_precedence=(opcompare,opaddition,opmultiply);
@ -1556,9 +1551,7 @@ unit pexpr;
var p1,p2:Ptree;
oldt:Ttoken;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
begin
@ -1574,9 +1567,7 @@ 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 }
@ -1585,9 +1576,7 @@ 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
@ -1613,20 +1602,16 @@ 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);
@ -1679,10 +1664,8 @@ unit pexpr;
end;
end;
afterassignment:=oldafterassignment;
{$ifdef UseTokenInfo}
if p1<>oldp1 then
set_tree_filepos(p1,filepos);
{$endif UseTokenInfo}
expr:=p1;
end;
@ -1732,7 +1715,17 @@ unit pexpr;
end.
{
$Log$
Revision 1.14 1998-05-11 13:07:56 peter
Revision 1.15 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.14 1998/05/11 13:07:56 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments

109
compiler/pmodules.pas
View File

@ -274,7 +274,7 @@ unit pmodules;
insertinternsyms(p);
end;
procedure load_ppu(hp : pmodule;compile_system : boolean);
procedure load_ppu(oldhp,hp : pmodule;compile_system : boolean);
var
loaded_unit : pmodule;
@ -322,7 +322,17 @@ unit pmodules;
if not(hp^.sources_avail) then
Message1(unit_f_cant_compile_unit,hp^.unitname^)
else
compile(hp^.mainsource^,compile_system);
begin
{$ifdef TEST_TEMPCLOSE}
if assigned(oldhp^.current_inputfile) then
oldhp^.current_inputfile^.tempclose;
{$endif TEST_TEMPCLOSE}
compile(hp^.mainsource^,compile_system);
{$ifdef TEST_TEMPCLOSE}
if not oldhp^.compiled then
oldhp^.current_inputfile^.tempreopen;
{$endif TEST_TEMPCLOSE}
end;
exit;
end;
@ -336,8 +346,10 @@ unit pmodules;
hp^.symtable:=new(punitsymtable,load(hp^.unitname^));
{ if this is the system unit insert the intern symbols }
make_ref:=false;
if compile_system then
insertinternsyms(psymtable(hp^.symtable));
make_ref:=true;
end;
{ now only read the implementation part }
@ -389,7 +401,17 @@ unit pmodules;
if not(hp^.sources_avail) then
Message1(unit_f_cant_compile_unit,hp^.unitname^)
else
compile(hp^.mainsource^,compile_system);
begin
{$ifdef TEST_TEMPCLOSE}
if assigned(oldhp^.current_inputfile) then
oldhp^.current_inputfile^.tempclose;
{$endif TEST_TEMPCLOSE}
compile(hp^.mainsource^,compile_system);
{$ifdef TEST_TEMPCLOSE}
if not oldhp^.compiled then
oldhp^.current_inputfile^.tempreopen;
{$endif TEST_TEMPCLOSE}
end;
exit;
end;
{ setup the map entry for deref }
@ -407,8 +429,10 @@ unit pmodules;
{ if this is the system unit insert the intern }
{ symbols }
make_ref:=false;
if compile_system then
insertinternsyms(psymtable(hp^.symtable));
make_ref:=true;
{ now only read the implementation part }
hp^.in_implementation:=true;
@ -443,7 +467,15 @@ unit pmodules;
if not(hp^.sources_avail) then
Message1(unit_f_cant_compile_unit,hp^.unitname^)
else
compile(hp^.mainsource^,compile_system);
begin
{ifdef TEST_TEMPCLOSE}
oldhp^.current_inputfile^.tempclose;
{endif TEST_TEMPCLOSE}
compile(hp^.mainsource^,compile_system);
{ifdef TEST_TEMPCLOSE}
oldhp^.current_inputfile^.tempclose;
{endif TEST_TEMPCLOSE}
end;
exit;
end; *)
{ read until ibend }
@ -514,7 +546,17 @@ unit pmodules;
if not(hp^.sources_avail) then
Message1(unit_f_cant_compile_unit,hp^.unitname^)
else
compile(hp^.mainsource^,compile_system);
begin
{$ifdef TEST_TEMPCLOSE}
if assigned(old_current_module^.current_inputfile) then
old_current_module^.current_inputfile^.tempclose;
{$endif TEST_TEMPCLOSE}
compile(hp^.mainsource^,compile_system);
{$ifdef TEST_TEMPCLOSE}
if not old_current_module^.compiled then
old_current_module^.current_inputfile^.tempreopen;
{$endif TEST_TEMPCLOSE}
end;
end
else
begin
@ -528,7 +570,7 @@ unit pmodules;
{$else}
if hp^.ppufile^.name^<>'' then
{$endif}
load_ppu(hp,compile_system);
load_ppu(old_current_module,hp,compile_system);
{ add the files for the linker }
addlinkerfiles(hp);
end;
@ -567,11 +609,24 @@ unit pmodules;
{ we must preserve the unit chain }
hp^.next:=nextmodule;
if assigned(hp^.ppufile) then
load_ppu(hp,compile_system)
load_ppu(old_current_module,hp,compile_system)
else
begin
{$ifdef UseBrowser}
{ here we need to remove the names ! }
hp^.sourcefiles.done;
hp^.sourcefiles.init;
{$endif not UseBrowser}
{$ifdef TEST_TEMPCLOSE}
if assigned(old_current_module^.current_inputfile) then
old_current_module^.current_inputfile^.tempclose;
{$endif TEST_TEMPCLOSE}
Message1(parser_d_compiling_second_time,hp^.mainsource^);
compile(hp^.mainsource^,compile_system);
{$ifdef TEST_TEMPCLOSE}
if not old_current_module^.compiled then
old_current_module^.current_inputfile^.tempreopen;
{$endif TEST_TEMPCLOSE}
end;
current_module^.compiled:=true;
end;
@ -841,7 +896,8 @@ unit pmodules;
}
{ generates static symbol table }
p:=new(punitsymtable,init(staticsymtable,current_module^.unitname^));
refsymtable:=p;
{ must be done only after _USES !! (PM)
refsymtable:=p;}
{Generate a procsym.}
aktprocsym:=new(Pprocsym,init(current_module^.unitname^+'_init'));
@ -864,6 +920,8 @@ unit pmodules;
symtablestack:=unitst^.next;
parse_implementation_uses(unitst);
{ now we can change refsymtable }
refsymtable:=p;
{ but reinsert the global symtable as lasts }
unitst^.next:=symtablestack;
@ -946,12 +1004,7 @@ unit pmodules;
pu:=pused_unit(pu^.next);
end;
inc(datasize,symtablestack^.datasize);
{ finish asmlist by adding segment starts }
{ finish asmlist by adding segment starts }
insertsegment;
end;
@ -1020,6 +1073,9 @@ unit pmodules;
refsymtable:=st;
{ necessary for browser }
loaded_units.insert(current_module);
{Insert the symbols of the system unit into the stack of symbol
tables.}
symtablestack:=systemunit;
@ -1081,24 +1137,27 @@ unit pmodules;
datasize:=symtablestack^.datasize;
symtablestack^.check_forwards;
{ symtablestack^.check_forwards;
symtablestack^.allsymbolsused;
{ finish asmlist by adding segment starts }
done in compile_proc_body }
{ finish asmlist by adding segment starts }
insertsegment;
end;
end.
{
$Log$
Revision 1.13 1998-05-12 10:47:00 peter
Revision 1.14 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.13 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

25
compiler/pp.pas
View File

@ -57,17 +57,17 @@
{ and only one of the two }
{$ifndef I386}
{$ifndef M68K}
{$fatalerror One of the switches I386 or M68K must be defined}
{$fatal One of the switches I386 or M68K must be defined}
{$endif M68K}
{$endif I386}
{$ifdef I386}
{$ifdef M68K}
{$fatalerror ONLY one of the switches I386 or M68K must be defined}
{$fatal ONLY one of the switches I386 or M68K must be defined}
{$endif M68K}
{$endif I386}
{$ifdef support_mmx}
{$ifndef i386}
{$fatalerror I386 switch must be on for MMX support}
{$fatal I386 switch must be on for MMX support}
{$endif i386}
{$endif support_mmx}
{$endif}
@ -195,6 +195,13 @@ var
procedure myexit;{$ifndef FPC}far;{$endif}
begin
exitproc:=oldexit;
{$ifdef UseBrowser}
if browser_file_open then
begin
close(browserfile);
browser_file_open:=false;
end;
{$endif UseBrowser}
{$ifdef tp}
if use_big then
symbolstream.done;
@ -353,7 +360,17 @@ begin
end.
{
$Log$
Revision 1.10 1998-05-12 10:47:00 peter
Revision 1.11 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.10 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

55
compiler/pstatmnt.pas
View File

@ -569,6 +569,12 @@ unit pstatmnt;
function _asm_statement : ptree;
begin
if (aktprocsym^.definition^.options and poinline)<>0 then
Begin
Comment(V_Warning,'asm statement inside inline procedure/function not yet supported');
Comment(V_Warning,'inlining disabled');
aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline;
End;
case aktasmmode of
I386_ATT : _asm_statement:=ratti386.assemble;
I386_INTEL : _asm_statement:=rai386.assemble;
@ -801,15 +807,11 @@ 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);
@ -845,11 +847,7 @@ unit pstatmnt;
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;
@ -859,17 +857,13 @@ unit pstatmnt;
p : ptree;
code : ptree;
labelnr : plabel;
{$ifdef UseTokenInfo}
filepos : tfileposinfo;
{$endif UseTokenInfo}
label
ready;
begin
{$ifdef UseTokenInfo}
filepos:=tokenpos;
{$endif UseTokenInfo}
case token of
_GOTO : begin
if not(cs_support_goto in aktswitches)then
@ -929,7 +923,9 @@ unit pstatmnt;
end;
}
_EXIT : code:=exit_statement;
_ASM : code:=_asm_statement;
_ASM : begin
code:=_asm_statement;
end;
else
begin
if (token=INTCONST) or
@ -938,6 +934,11 @@ unit pstatmnt;
(pattern='RESULT'))) then
begin
getsym(pattern,false);
lastsymknown:=true;
lastsrsym:=srsym;
{ it is NOT necessarily the owner
it can be a withsymtable !!! }
lastsrsymtable:=srsymtable;
if assigned(srsym) and (srsym^.typ=labelsym) then
begin
consume(token);
@ -948,7 +949,7 @@ unit pstatmnt;
{ statement modifies srsym }
labelnr:=plabelsym(srsym)^.number;
lastsymknown:=false;
{ the pointer to the following instruction }
{ isn't a very clean way }
{$ifdef tp}
@ -965,13 +966,19 @@ unit pstatmnt;
if not(p^.treetype in [calln,assignn,breakn,inlinen,
continuen]) then
Message(cg_e_illegal_expression);
{ specify that we don't use the value returned by the call }
{ Question : can this be also improtant
for inlinen ??
it is used for :
- dispose of temp stack space
- dispose on FPU stack }
if p^.treetype=calln then
p^.return_value_used:=false;
code:=p;
end;
end;
ready:
{$ifdef UseTokenInfo}
set_tree_filepos(code,filepos);
{$endif UseTokenInfo}
statement:=code;
end;
@ -1091,8 +1098,10 @@ unit pstatmnt;
end;
{ set the framepointer to esp for assembler functions }
{ but only if the are no local variables }
{ added no parameter also (PM) }
if ((aktprocsym^.definition^.options and poassembler)<>0) and
(aktprocsym^.definition^.localst^.datasize=0) then
(aktprocsym^.definition^.localst^.datasize=0) and
(aktprocsym^.definition^.parast^.datasize=0) then
begin
{$ifdef i386}
procinfo.framepointer:=R_ESP;
@ -1110,7 +1119,17 @@ unit pstatmnt;
end.
{
$Log$
Revision 1.10 1998-05-11 13:07:56 peter
Revision 1.11 1998-05-20 09:42:35 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.10 1998/05/11 13:07:56 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments

17
compiler/ra68k.pas
View File

@ -73,7 +73,7 @@ var
Implementation
uses
globals,AsmUtils,strings,hcodegen,scanner,aasm,
files,globals,AsmUtils,strings,hcodegen,scanner,aasm,
cobjects,verbose,symtable;
@ -249,6 +249,9 @@ var
end;
{ Possiblities for first token in a statement: }
{ Local Label, Label, Directive, Prefix or Opcode.... }
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
if firsttoken and not (c in [newline,#13,'{',';']) then
begin
@ -2169,7 +2172,17 @@ Begin
end.
{
$Log$
Revision 1.2 1998-04-29 10:34:01 pierre
Revision 1.3 1998-05-20 09:42:36 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.2 1998/04/29 10:34:01 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output

19
compiler/radi386.pas
View File

@ -32,7 +32,7 @@ unit radi386;
implementation
uses
i386,hcodegen,globals,scanner,aasm,
files,i386,hcodegen,globals,scanner,aasm,
cobjects,symtable,types,verbose,asmutils;
function assemble : ptree;
@ -73,10 +73,13 @@ unit radi386;
retstr:=upper(tostr(procinfo.retoffset)+'('+att_reg2str[procinfo.framepointer]+')')
else
retstr:='';
c:=asmgetchar;
c:=asmgetchar;
code:=new(paasmoutput,init);
while not(ende) do
begin
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
case c of
'A'..'Z','a'..'z','_' : begin
hs:='';
@ -236,7 +239,17 @@ unit radi386;
end.
{
$Log$
Revision 1.2 1998-04-08 16:58:06 pierre
Revision 1.3 1998-05-20 09:42:36 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.2 1998/04/08 16:58:06 pierre
* several bugfixes
ADD ADC and AND are also sign extended
nasm output OK (program still crashes at end

17
compiler/rai386.pas
View File

@ -82,7 +82,7 @@ var
Implementation
Uses
aasm,globals,AsmUtils,strings,hcodegen,scanner,
files,aasm,globals,AsmUtils,strings,hcodegen,scanner,
cobjects,verbose,types;
@ -350,6 +350,9 @@ var
c := asmgetchar;
{ Possiblities for first token in a statement: }
{ Local Label, Label, Directive, Prefix or Opcode.... }
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
if firsttoken and not (c in [newline,#13,'{',';']) then
begin
firsttoken := FALSE;
@ -3366,7 +3369,17 @@ Begin
end.
{
$Log$
Revision 1.4 1998-04-29 10:34:03 pierre
Revision 1.5 1998-05-20 09:42:36 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.4 1998/04/29 10:34:03 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output

17
compiler/ratti386.pas
View File

@ -75,7 +75,7 @@ var
Implementation
Uses
aasm,globals,AsmUtils,strings,hcodegen,scanner,
files,aasm,globals,AsmUtils,strings,hcodegen,scanner,
cobjects,verbose,symtable,types;
type
@ -327,6 +327,9 @@ const
c:=asmgetchar;
{ Possiblities for first token in a statement: }
{ Local Label, Label, Directive, Prefix or Opcode.... }
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
if firsttoken and not (c in [newline,#13,'{',';']) then
begin
firsttoken := FALSE;
@ -3678,7 +3681,17 @@ end.
{
$Log$
Revision 1.5 1998-04-29 13:52:23 peter
Revision 1.6 1998-05-20 09:42:37 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.5 1998/04/29 13:52:23 peter
* small optimize fix
Revision 1.4 1998/04/29 10:34:04 pierre

217
compiler/scanner.pas
View File

@ -160,15 +160,7 @@ unit scanner;
preprocstack : ppreprocstack;
{$ifdef UseTokenInfo}
{ type
ttokeninfo = record
token : ttoken;
fi : tfileposinfo;
end;
ptokeninfo = ^ttokeninfo; }
var tokenpos : tfileposinfo;
{$endif UseTokenInfo}
{public}
procedure syntaxerror(const s : string);
@ -659,24 +651,17 @@ unit scanner;
function yylex : ttoken;
var
y : ttoken;
{$ifdef UseTokenInfo}
fileindex,line,column : longint;
{$endif UseTokenInfo}
code : word;
l : longint;
mac : pmacrosym;
hp : pinputfile;
hp2 : pchar;
{$ifdef UseTokenInfo}
label
exit_label;
{$endif UseTokenInfo}
begin
{$ifdef UseTokenInfo}
line:=current_module^.current_inputfile^.line_no;
column:=get_current_col;
fileindex:=current_module^.current_index;
{$endif UseTokenInfo}
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
{ was the last character a point ? }
{ this code is needed because the scanner if there is a 1. found if }
{ this is a floating point number or range like 1..3 }
@ -686,39 +671,29 @@ unit scanner;
if c='.' then
begin
readchar;
{$ifndef UseTokenInfo}
yylex:=POINTPOINT;
exit;
end;
yylex:=POINT;
exit;
{$else UseTokenInfo}
yylex:=POINTPOINT;
goto exit_label;
end;
yylex:=POINT;
goto exit_label;
{$endif UseTokenInfo}
end;
repeat
case c of
'{' : skipcomment;
' ',#9..#13 : skipspace;
' ',#9..#13 : skipspace;
else
break;
end;
until false;
lasttokenpos:=longint(inputpointer);
{$ifdef UseTokenInfo}
line:=current_module^.current_inputfile^.line_no;
column:=get_current_col;
fileindex:=current_module^.current_index;
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
{ will become line:=lasttokenpos ??;}
{$endif UseTokenInfo}
case c of
'_','A'..'Z',
'_','A'..'Z',
'a'..'z' : begin
orgpattern:=readstring;
pattern:=upper(orgpattern);
@ -740,6 +715,9 @@ unit scanner;
hp^.next:=current_module^.current_inputfile;
current_module^.current_inputfile:=hp;
status.currentsource:=current_module^.current_inputfile^.name^;
{ I don't think that we should do that
because otherwise the file will be searched !! (PM)
but there is the problem of index !! }
current_module^.sourcefiles.register_file(hp);
current_module^.current_index:=hp^.ref_index;
{ set an own buffer }
@ -772,29 +750,17 @@ unit scanner;
end;
yylex:=ID;
end;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'$' : begin
pattern:=readnumber;
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'%' : begin
pattern:=readnumber;
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'0'..'9' : begin
pattern:=readnumber;
@ -805,11 +771,7 @@ unit scanner;
begin
s_point:=true;
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
pattern:=pattern+'.';
while c in ['0'..'9'] do
@ -818,11 +780,7 @@ unit scanner;
readchar;
end;
yylex:=REALNUMBER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'e','E' : begin
pattern:=pattern+'E';
@ -840,46 +798,26 @@ unit scanner;
readchar;
end;
yylex:=REALNUMBER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
end;
yylex:=INTCONST;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
';' : begin
readchar;
yylex:=SEMICOLON;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'[' : begin
readchar;
yylex:=LECKKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
']' : begin
readchar;
yylex:=RECKKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'(' : begin
readchar;
@ -894,20 +832,12 @@ unit scanner;
exit;
end;
yylex:=LKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
')' : begin
readchar;
yylex:=RKLAMMER;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'+' : begin
readchar;
@ -915,18 +845,10 @@ unit scanner;
begin
readchar;
yylex:=_PLUSASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
yylex:=PLUS;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'-' : begin
readchar;
@ -934,18 +856,10 @@ unit scanner;
begin
readchar;
yylex:=_MINUSASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
yylex:=MINUS;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
':' : begin
readchar;
@ -953,18 +867,10 @@ unit scanner;
begin
readchar;
yylex:=ASSIGNMENT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
yylex:=COLON;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'*' : begin
readchar;
@ -979,11 +885,7 @@ unit scanner;
end
else
yylex:=STAR;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'/' : begin
readchar;
@ -993,11 +895,7 @@ unit scanner;
begin
readchar;
yylex:=_SLASHASN;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
end;
'/' : begin
@ -1011,20 +909,12 @@ unit scanner;
end;
end;
yylex:=SLASH;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'=' : begin
readchar;
yylex:=EQUAL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'.' : begin
readchar;
@ -1032,19 +922,11 @@ unit scanner;
begin
readchar;
yylex:=POINTPOINT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end
else
yylex:=POINT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'@' : begin
readchar;
@ -1055,20 +937,12 @@ unit scanner;
end
else
yylex:=KLAMMERAFFE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
',' : begin
readchar;
yylex:=COMMA;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'''','#','^' : begin
if c='^' then
@ -1084,11 +958,7 @@ unit scanner;
else
begin
yylex:=CARET;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
end
else
@ -1135,11 +1005,7 @@ unit scanner;
yylex:=CCHAR
else
yylex:=CSTRING;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'>' : begin
readchar;
@ -1147,37 +1013,21 @@ unit scanner;
'=' : begin
readchar;
yylex:=GTE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'>' : begin
readchar;
yylex:=_SHR;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'<' : begin { >< is for a symetric diff for sets }
readchar;
yylex:=SYMDIF;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
end;
yylex:=GT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'<' : begin
readchar;
@ -1185,57 +1035,32 @@ unit scanner;
'>' : begin
readchar;
yylex:=UNEQUAL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'=' : begin
readchar;
yylex:=LTE;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
'<' : begin
readchar;
yylex:=_SHL;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
end;
yylex:=LT;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
#26 : begin
yylex:=_EOF;
{$ifndef UseTokenInfo}
exit;
{$else UseTokenInfo}
goto exit_label;
{$endif UseTokenInfo}
end;
else
begin
Message(scan_f_illegal_char);
end;
end;
{$ifdef UseTokenInfo}
exit_label:
tokenpos.fileindex:=fileindex;
tokenpos.line:=line;
tokenpos.column:=column;
{$endif UseTokenInfo}
exit_label:
end;
@ -1248,6 +1073,9 @@ unit scanner;
end
else
readchar;
tokenpos.line:=current_module^.current_inputfile^.line_no;
tokenpos.column:=get_current_col;
tokenpos.fileindex:=current_module^.current_index;
case c of
'{' : begin
skipcomment;
@ -1326,7 +1154,8 @@ unit scanner;
current_module^.current_index:=fileinfo.fileindex;
current_module^.current_inputfile:=
pinputfile(current_module^.sourcefiles.get_file(fileinfo.fileindex));
current_module^.current_inputfile^.line_no:=fileinfo.line;
if assigned(current_module^.current_inputfile) then
current_module^.current_inputfile^.line_no:=fileinfo.line;
{fileinfo.fileindex:=current_module^.current_inputfile^.ref_index;}
{ should allways be the same !! }
{ fileinfo.column:=get_current_col; }
@ -1389,7 +1218,17 @@ unit scanner;
end.
{
$Log$
Revision 1.18 1998-05-12 10:47:00 peter
Revision 1.19 1998-05-20 09:42:37 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.18 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default

157
compiler/tgeni386.pas
View File

@ -58,7 +58,12 @@ unit tgeni386;
procedure setfirsttemp(l : longint);
function gettempsize : longint;
function gettempofsize(size : longint) : longint;
{ special call for inlined procedures }
function gettempofsizepersistant(size : longint) : longint;
{ for parameter func returns }
procedure persistanttemptonormal(pos : longint);
procedure ungettemp(pos : longint;size : longint);
procedure ungetpersistanttemp(pos : longint;size : longint);
procedure gettempofsizereference(l : longint;var ref : treference);
function istemp(const ref : treference) : boolean;
procedure ungetiftemp(const ref : treference);
@ -321,6 +326,7 @@ unit tgeni386;
next : pfreerecord;
pos : longint;
size : longint;
persistant : boolean; { used for inlined procedures }
{$ifdef EXTDEBUG}
line : longint;
{$endif}
@ -348,7 +354,7 @@ unit tgeni386;
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'temporary assignment of size '
+tostr(templist^.size)+' from '+tostr(templist^.line)+
+tostr(templist^.size)+' from line '+tostr(templist^.line)+
+' at pos '+tostr(templist^.pos)+
' not freed at the end of the procedure');
{$endif}
@ -378,12 +384,14 @@ unit tgeni386;
function gettempofsize(size : longint) : longint;
var
last,hp : pfreerecord;
tl,last,hp : pfreerecord;
ofs : longint;
begin
{ this code comes from the heap management of FPC ... }
if (size mod 4)<>0 then
size:=size+(4-(size mod 4));
ofs:=0;
if assigned(tmpfreelist) then
begin
last:=nil;
@ -393,7 +401,7 @@ unit tgeni386;
{ first fit }
if hp^.size>=size then
begin
gettempofsize:=hp^.pos;
ofs:=hp^.pos;
if hp^.pos-size < maxtemp then
maxtemp := hp^.size-size;
{ the whole block is needed ? }
@ -410,17 +418,45 @@ unit tgeni386;
tmpfreelist:=nil;
dispose(hp);
end;
exit;
break;
end;
last:=hp;
hp:=hp^.next;
end;
end;
{ nothing free is big enough : expand temp }
gettempofsize:=lastoccupied-size;
lastoccupied:=lastoccupied-size;
if lastoccupied < maxtemp then
maxtemp := lastoccupied;
if ofs=0 then
begin
ofs:=lastoccupied-size;
lastoccupied:=lastoccupied-size;
if lastoccupied < maxtemp then
maxtemp := lastoccupied;
end;
new(tl);
tl^.pos:=ofs;
tl^.size:=size;
tl^.next:=templist;
tl^.persistant:=false;
templist:=tl;
{$ifdef EXTDEBUG}
tl^.line:=current_module^.current_inputfile^.line_no;
{$endif}
gettempofsize:=ofs;
end;
function gettempofsizepersistant(size : longint) : longint;
var
l : longint;
begin
l:=gettempofsize(size);
templist^.persistant:=true;
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp managment : call to gettempofsizepersistant()'+
' with size '+tostr(size)+' returned '+tostr(l));
{$endif}
gettempofsizepersistant:=l;
end;
function gettempsize : longint;
@ -434,29 +470,77 @@ unit tgeni386;
procedure gettempofsizereference(l : longint;var ref : treference);
var
tl : pfreerecord;
begin
{ do a reset, because the reference isn't used }
reset_reference(ref);
ref.offset:=gettempofsize(l);
ref.base:=procinfo.framepointer;
new(tl);
tl^.pos:=ref.offset;
tl^.size:=l;
tl^.next:=templist;
templist:=tl;
{$ifdef EXTDEBUG}
tl^.line:=current_module^.current_inputfile^.line_no;
{$endif}
end;
function istemp(const ref : treference) : boolean;
begin
{ ref.index = R_NO was missing
led to problems with local arrays
with lower bound > 0 (PM) }
istemp:=((ref.base=procinfo.framepointer) and
(ref.offset<firsttemp));
(ref.offset<firsttemp) and (ref.index=R_NO));
end;
procedure persistanttemptonormal(pos : longint);
var hp : pfreerecord;
begin
hp:=templist;
while assigned(hp) do
if (hp^.persistant) and (hp^.pos=pos) then
begin
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp managment : persistanttemptonormal()'+
' at pos '+tostr(pos)+ ' found !');
{$endif}
hp^.persistant:=false;
exit;
end
else
hp:=hp^.next;
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp managment problem : persistanttemptonormal()'+
' at pos '+tostr(pos)+ ' not found !');
{$endif}
end;
procedure ungetpersistanttemp(pos : longint;size : longint);
var
prev,hp : pfreerecord;
begin
ungettemp(pos,size);
prev:=nil;
hp:=templist;
while assigned(hp) do
begin
if (hp^.persistant) and (hp^.pos=pos) and (hp^.size=size) then
begin
if assigned(prev) then
prev^.next:=hp^.next
else
templist:=hp^.next;
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp managment : ungetpersistanttemp()'+
' at pos '+tostr(pos)+ ' found !');
{$endif}
dispose(hp);
exit;
end;
prev:=hp;
hp:=hp^.next;
end;
{$ifdef EXTDEBUG}
Comment(V_Warning,'temp managment problem : ungetpersistanttemp()'+
' at pos '+tostr(pos)+ ' not found !');
{$endif}
end;
procedure ungettemp(pos : longint;size : longint);
@ -469,6 +553,7 @@ unit tgeni386;
size:=size+(4-(size mod 4));
if size = 0 then
exit;
if pos<=lastoccupied then
if pos=lastoccupied then
begin
@ -493,7 +578,8 @@ unit tgeni386;
else
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'temp managment problem : ungettemp() pos < lastoccupied !');
Comment(V_Warning,'temp managment problem : ungettemp()'+
'pos '+tostr(pos)+ '< lastoccupied '+tostr(lastoccupied)+' !');
{$endif}
end
else
@ -564,9 +650,24 @@ unit tgeni386;
tl:=templist;
while assigned(tl) do
begin
if ref.offset=tl^.pos then
{ no release of persistant blocks this way!! }
if tl^.persistant then
if (ref.offset>=tl^.pos) and
(ref.offset<tl^.pos+tl^.size) then
begin
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp '+
' at pos '+tostr(ref.offset)+ ' not released because persistant !');
{$endif}
exit;
end;
if (ref.offset=tl^.pos) then
begin
ungettemp(ref.offset,tl^.size);
{$ifdef TEMPDEBUG}
Comment(V_Debug,'temp managment : ungettemp()'+
' at pos '+tostr(tl^.pos)+ ' found !');
{$endif}
if assigned(prev) then
prev^.next:=tl^.next
else
@ -598,7 +699,17 @@ begin
end.
{
$Log$
Revision 1.5 1998-05-11 13:07:58 peter
Revision 1.6 1998-05-20 09:42:38 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.5 1998/05/11 13:07:58 peter
+ $ifdef NEWPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments

128
compiler/tree.pas
View File

@ -206,7 +206,7 @@ unit tree;
calln : (symtableprocentry : pprocsym;
symtableproc : psymtable;procdefinition : pprocdef;
methodpointer : ptree;
no_check,unit_specific : boolean);
no_check,unit_specific,return_value_used : boolean);
ordconstn : (value : longint);
realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint);
@ -224,7 +224,8 @@ unit tree;
{$endif UseAnsiString}
typeconvn : (convtyp : tconverttype;explizit : boolean);
inlinen : (inlinenumber : longint);
procinlinen : (inlineprocdef : pprocdef);
procinlinen : (inlineprocdef : pprocdef;
retoffset,para_offset,para_size : longint);
setconstrn : (constset : pconstset);
loopn : (t1,t2 : ptree;backward : boolean);
asmn : (p_asm : paasmoutput);
@ -283,7 +284,7 @@ unit tree;
procedure set_current_file_line(_to : ptree);
procedure set_tree_filepos(p : ptree;const filepos : tfileposinfo);
{$ifdef extdebug}
procedure compare_trees(p1,p2 : ptree);
procedure compare_trees(oldp,p : ptree);
const
maxfirstpasscount : longint = 0;
{$endif extdebug}
@ -345,11 +346,7 @@ unit tree;
hp^.error:=false;
{ we know also the position }
{$ifdef UseTokenInfo}
hp^.fileinfo:=tokenpos;
{$else UseTokenInfo}
get_cur_file_pos(hp^.fileinfo);
{$endif UseTokenInfo}
hp^.pragmas:=aktswitches;
getnode:=hp;
end;
@ -989,6 +986,7 @@ unit tree;
p^.symtableproc:=st;
p^.unit_specific:=false;
p^.no_check:=false;
p^.return_value_used:=true;
p^.disposetyp := dt_leftright;
p^.methodpointer:=nil;
p^.left:=nil;
@ -1012,7 +1010,7 @@ unit tree;
p^.registersmmx:=0;
{$endif SUPPORT_MMX}
p^.treetype:=calln;
p^.return_value_used:=true;
p^.symtableprocentry:=v;
p^.symtableproc:=st;
p^.disposetyp:=dt_mbleft_and_method;
@ -1142,6 +1140,9 @@ unit tree;
p^.disposetyp:=dt_left;
p^.treetype:=procinlinen;
p^.inlineprocdef:=callp^.procdefinition;
p^.retoffset:=-4; { less dangerous as zero (PM) }
p^.para_offset:=0;
p^.para_size:=p^.inlineprocdef^.para_size;
{ copy args }
p^.left:=getcopy(code);
p^.registers32:=code^.registers32;
@ -1175,110 +1176,117 @@ unit tree;
end;
{$ifdef extdebug}
procedure compare_trees(p1,p2 : ptree);
procedure compare_trees(oldp,p : ptree);
var
error_found : boolean;
begin
if p1^.error<>p2^.error then
if oldp^.resulttype<>p^.resulttype then
begin
error_found:=true;
if is_equal(oldp^.resulttype,p^.resulttype) then
comment(v_debug,'resulttype fields are different but equal')
else
comment(v_warning,'resulttype fields are really different');
end;
if oldp^.treetype<>p^.treetype then
begin
comment(v_warning,'treetype field different');
error_found:=true;
end
else
comment(v_debug,' treetype '+tostr(longint(oldp^.treetype)));
if oldp^.error<>p^.error then
begin
comment(v_warning,'error field different');
error_found:=true;
end;
if p1^.disposetyp<>p2^.disposetyp then
if oldp^.disposetyp<>p^.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
if oldp^.swaped<>p^.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
if oldp^.location.loc<>p^.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
if oldp^.registers32<>p^.registers32 then
begin
comment(v_warning,'registers32 field different');
comment(v_warning,tostr(p1^.registers32)+'<>'+tostr(p2^.registers32));
comment(v_warning,' old '+tostr(oldp^.registers32)+'<> new '+tostr(p^.registers32));
error_found:=true;
end;
if p1^.registersfpu<>p2^.registersfpu then
if oldp^.registersfpu<>p^.registersfpu then
begin
comment(v_warning,'registersfpu field different');
error_found:=true;
end;
{$ifdef SUPPORT_MMX}
if p1^.registersmmx<>p2^.registersmmx then
if oldp^.registersmmx<>p^.registersmmx then
begin
comment(v_warning,'registersmmx field different');
error_found:=true;
end;
{$endif SUPPORT_MMX}
if p1^.left<>p2^.left then
if oldp^.left<>p^.left then
begin
comment(v_warning,'left field different');
error_found:=true;
end;
if p1^.right<>p2^.right then
if oldp^.right<>p^.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
if oldp^.fileinfo.line<>p^.fileinfo.line then
begin
comment(v_warning,'fileinfo.line field different');
error_found:=true;
end;
if p1^.fileinfo.column<>p2^.fileinfo.column then
if oldp^.fileinfo.column<>p^.fileinfo.column then
begin
comment(v_warning,'fileinfo.column field different');
error_found:=true;
end;
if p1^.fileinfo.fileindex<>p2^.fileinfo.fileindex then
if oldp^.fileinfo.fileindex<>p^.fileinfo.fileindex then
begin
comment(v_warning,'fileinfo.fileindex field different');
error_found:=true;
end;
if p1^.pragmas<>p2^.pragmas then
if oldp^.pragmas<>p^.pragmas then
begin
comment(v_warning,'pragmas field different');
error_found:=true;
end;
{$ifdef extdebug}
if p1^.firstpasscount<>p2^.firstpasscount then
if oldp^.firstpasscount<>p^.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
if oldp^.treetype=p^.treetype then
case oldp^.treetype of
addn :
begin
if p1^.use_strconcat<>p2^.use_strconcat then
if oldp^.use_strconcat<>p^.use_strconcat then
begin
comment(v_warning,'use_strconcat field different');
error_found:=true;
end;
if p1^.string_typ<>p2^.string_typ then
if oldp^.string_typ<>p^.string_typ then
begin
comment(v_warning,'stringtyp field different');
error_found:=true;
@ -1287,12 +1295,12 @@ unit tree;
callparan :
{(is_colon_para : boolean;exact_match_found : boolean);}
begin
if p1^.is_colon_para<>p2^.is_colon_para then
if oldp^.is_colon_para<>p^.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
if oldp^.exact_match_found<>p^.exact_match_found then
begin
comment(v_warning,'exact_match_found field different');
error_found:=true;
@ -1301,12 +1309,12 @@ unit tree;
assignn :
{(assigntyp : tassigntyp;concat_string : boolean);}
begin
if p1^.assigntyp<>p2^.assigntyp then
if oldp^.assigntyp<>p^.assigntyp then
begin
comment(v_warning,'assigntyp field different');
error_found:=true;
end;
if p1^.concat_string<>p2^.concat_string then
if oldp^.concat_string<>p^.concat_string then
begin
comment(v_warning,'concat_string field different');
error_found:=true;
@ -1316,22 +1324,22 @@ unit tree;
{(symtableentry : psym;symtable : psymtable;
is_absolute,is_first : boolean);}
begin
if p1^.symtableentry<>p2^.symtableentry then
if oldp^.symtableentry<>p^.symtableentry then
begin
comment(v_warning,'symtableentry field different');
error_found:=true;
end;
if p1^.symtable<>p2^.symtable then
if oldp^.symtable<>p^.symtable then
begin
comment(v_warning,'symtable field different');
error_found:=true;
end;
if p1^.is_absolute<>p2^.is_absolute then
if oldp^.is_absolute<>p^.is_absolute then
begin
comment(v_warning,'is_absolute field different');
error_found:=true;
end;
if p1^.is_first<>p2^.is_first then
if oldp^.is_first<>p^.is_first then
begin
comment(v_warning,'is_first field different');
error_found:=true;
@ -1343,32 +1351,32 @@ unit tree;
methodpointer : ptree;
no_check,unit_specific : boolean);}
begin
if p1^.symtableprocentry<>p2^.symtableprocentry then
if oldp^.symtableprocentry<>p^.symtableprocentry then
begin
comment(v_warning,'symtableprocentry field different');
error_found:=true;
end;
if p1^.symtableproc<>p2^.symtableproc then
if oldp^.symtableproc<>p^.symtableproc then
begin
comment(v_warning,'symtableproc field different');
error_found:=true;
end;
if p1^.procdefinition<>p2^.procdefinition then
if oldp^.procdefinition<>p^.procdefinition then
begin
comment(v_warning,'procdefinition field different');
error_found:=true;
end;
if p1^.methodpointer<>p2^.methodpointer then
if oldp^.methodpointer<>p^.methodpointer then
begin
comment(v_warning,'methodpointer field different');
error_found:=true;
end;
if p1^.no_check<>p2^.no_check then
if oldp^.no_check<>p^.no_check then
begin
comment(v_warning,'no_check field different');
error_found:=true;
end;
if p1^.unit_specific<>p2^.unit_specific then
if oldp^.unit_specific<>p^.unit_specific then
begin
error_found:=true;
comment(v_warning,'unit_specific field different');
@ -1376,7 +1384,7 @@ unit tree;
end;
ordconstn :
begin
if p1^.value<>p2^.value then
if oldp^.value<>p^.value then
begin
comment(v_warning,'value field different');
error_found:=true;
@ -1384,17 +1392,17 @@ unit tree;
end;
realconstn :
begin
if p1^.valued<>p2^.valued then
if oldp^.valued<>p^.valued then
begin
comment(v_warning,'valued field different');
error_found:=true;
end;
if p1^.labnumber<>p2^.labnumber then
if oldp^.labnumber<>p^.labnumber then
begin
comment(v_warning,'labnumber field different');
error_found:=true;
end;
if p1^.realtyp<>p2^.realtyp then
if oldp^.realtyp<>p^.realtyp then
begin
comment(v_warning,'realtyp field different');
error_found:=true;
@ -1527,7 +1535,17 @@ unit tree;
end.
{
$Log$
Revision 1.9 1998-05-12 10:47:00 peter
Revision 1.10 1998-05-20 09:42:38 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.9 1998/05/12 10:47:00 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default