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

+ Compiler,Comphook unit which are the new interface units to the

Browse Source 
compiler
This commit is contained in:
peter 1998-08-10 10:18:23 +00:00
parent 3a6d38ad23
commit 6396267185
14 changed files with 1236 additions and 667 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler/cgi386.pas
View File

@ -57,7 +57,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
implementation
uses
verbose,cobjects,systems,globals,files,
cobjects,verbose,comphook,systems,globals,files,
symtable,types,aasm,scanner,
pass_1,hcodegen,temp_gen
{$ifdef GDB}
@ -474,7 +474,7 @@ implementation
{ dummy }
regsize:=S_W;
end;
if (verbosity and v_debug)=v_debug then
if (status.verbosity and v_debug)=v_debug then
begin
for i:=1 to maxvarregs do
begin
@ -507,7 +507,11 @@ implementation
end.
{
$Log$
Revision 1.45 1998-07-30 13:30:34 florian
Revision 1.46 1998-08-10 10:18:23 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.45 1998/07/30 13:30:34 florian
* final implemenation of exception support, maybe it needs
some fixes :)

300
compiler/comphook.pas Normal file
View File

@ -0,0 +1,300 @@
{
$Id$
Copyright (c) 1998 by Peter Vreman
This unit handles the compilerhooks for output to external programs
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit comphook;
interface
Const
{ <$10000 will show file and line }
V_Fatal = $0;
V_Error = $1;
V_Normal = $2; { doesn't show a text like Error: }
V_Warning = $4;
V_Note = $8;
V_Hint = $10;
V_Macro = $100;
V_Procedure = $200;
V_Conditional = $400;
V_Info = $10000;
V_Status = $20000;
V_Used = $40000;
V_Tried = $80000;
V_Debug = $100000;
V_ShowFile = $ffff;
V_All = $ffffffff;
V_Default = V_Fatal + V_Error + V_Normal;
type
PCompilerStatus = ^TCompilerStatus;
TCompilerStatus = record
{ Current status }
currentmodule,
currentsource : string; { filename }
currentline,
currentcolumn : longint; { current line and column }
{ Total Status }
compiledlines : longint; { the number of lines which are compiled }
errorcount : longint; { number of generated errors }
{ Settings for the output }
verbosity : longint;
maxerrorcount : longint;
use_stderr,
use_redir,
use_gccoutput : boolean;
{ Redirection support }
redirfile : text;
end;
var
status : tcompilerstatus;
{ Default Functions }
procedure def_stop;
Function def_status:boolean;
Function def_comment(Level:Longint;const s:string):boolean;
function def_internalerror(i:longint):boolean;
{ Function redirecting for IDE support }
type
tstopprocedure = procedure;
tstatusfunction = function:boolean;
tcommentfunction = function(Level:Longint;const s:string):boolean;
tinternalerrorfunction = function(i:longint):boolean;
const
do_stop : tstopprocedure = def_stop;
do_status : tstatusfunction = def_status;
do_comment : tcommentfunction = def_comment;
do_internalerror : tinternalerrorfunction = def_internalerror;
implementation
{****************************************************************************
Helper Routines
****************************************************************************}
function gccfilename(const s : string) : string;
var
i : longint;
begin
for i:=1to length(s) do
begin
case s[i] of
'\' : gccfilename[i]:='/';
'A'..'Z' : gccfilename[i]:=chr(ord(s[i])+32);
else
gccfilename[i]:=s[i];
end;
end;
gccfilename[0]:=s[0];
end;
function tostr(i : longint) : string;
var
hs : string;
begin
str(i,hs);
tostr:=hs;
end;
{****************************************************************************
Predefined default Handlers
****************************************************************************}
{ predefined handler when then compiler stops }
procedure def_stop;
begin
Halt(1);
end;
function def_status:boolean;
begin
def_status:=false; { never stop }
{ Status info?, Called every line }
if ((status.verbosity and V_Status)<>0) then
begin
if (status.compiledlines=1) then
WriteLn(memavail shr 10,' Kb Free');
if (status.currentline>0) and (status.currentline mod 100=0) then
{$ifdef FPC}
WriteLn(status.currentline,' ',memavail shr 10,'/',system.heapsize shr 10,' Kb Free');
{$else}
WriteLn(status.currentline,' ',memavail shr 10,' Kb Free');
{$endif}
end
end;
Function def_comment(Level:Longint;const s:string):boolean;
const
{ RHIDE expect gcc like error output }
rh_errorstr='error: ';
rh_warningstr='warning: ';
fatalstr='Fatal: ';
errorstr='Error: ';
warningstr='Warning: ';
notestr='Note: ';
hintstr='Hint: ';
var
hs : string;
begin
def_comment:=false; { never stop }
if (status.verbosity and Level)=Level then
begin
hs:='';
if not(status.use_gccoutput) then
begin
if (status.verbosity and Level)=V_Hint then
hs:=hintstr;
if (status.verbosity and Level)=V_Note then
hs:=notestr;
if (status.verbosity and Level)=V_Warning then
hs:=warningstr;
if (status.verbosity and Level)=V_Error then
hs:=errorstr;
if (status.verbosity and Level)=V_Fatal then
hs:=fatalstr;
end
else
begin
if (status.verbosity and Level)=V_Hint then
hs:=rh_warningstr;
if (status.verbosity and Level)=V_Note then
hs:=rh_warningstr;
if (status.verbosity and Level)=V_Warning then
hs:=rh_warningstr;
if (status.verbosity and Level)=V_Error then
hs:=rh_errorstr;
if (status.verbosity and Level)=V_Fatal then
hs:=rh_errorstr;
end;
if (Level<=V_ShowFile) and (status.currentline>0) then
begin
{ Adding the column should not confuse RHIDE,
even if it does not yet use it PM }
if status.use_gccoutput then
hs:=gccfilename(status.currentsource)+':'+tostr(status.currentline)
+':'+tostr(status.currentcolumn)+': '+hs
else
hs:=status.currentsource+'('+tostr(status.currentline)
+','+tostr(status.currentcolumn)+') '+hs;
end;
{ add the message to the text }
hs:=hs+s;
{$ifdef FPC}
if status.use_stderr then
begin
writeln(stderr,hs);
flush(stderr);
end
else
{$endif}
begin
if status.use_redir then
writeln(status.redirfile,hs)
else
writeln(hs);
end;
end;
end;
function def_internalerror(i : longint) : boolean;
begin
do_comment(V_Fatal,'Internal error '+tostr(i));
def_internalerror:=true;
end;
end.
{
$Log$
Revision 1.1 1998-08-10 10:18:24 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.14 1998/08/04 13:22:48 pierre
* weird bug fixed :
a pchar ' ' (simple space or any other letter) was found to
be equal to a string of length zero !!!
thus printing out non sense
found that out while checking Control-C !!
+ added column info also in RHIDE format as
it might be usefull later
Revision 1.13 1998/07/14 14:47:12 peter
* released NEWINPUT
Revision 1.12 1998/07/07 11:20:19 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.11 1998/06/19 15:40:00 peter
* bp7 fix
Revision 1.10 1998/06/16 11:32:19 peter
* small cosmetic fixes
Revision 1.9 1998/05/23 01:21:33 peter
+ aktasmmode, aktoptprocessor, aktoutputformat
+ smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+ $LIBNAME to set the library name where the unit will be put in
* splitted cgi386 a bit (codeseg to large for bp7)
* nasm, tasm works again. nasm moved to ag386nsm.pas
Revision 1.8 1998/05/21 19:33:38 peter
+ better procedure directive handling and only one table
Revision 1.7 1998/05/12 10:47:01 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
* fixed some messages
* first time parameter scan is only for -v and -T
- removed old style messages
Revision 1.6 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
* no findfirst/findnext anymore to remove smartlink *.o files
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
* fixed one remaining bug in scanner for line counts
* several little fixes
Revision 1.4 1998/04/29 10:34:09 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
}

217
compiler/compiler.pas Normal file
View File

@ -0,0 +1,217 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
This unit is the interface of the compiler which can be used by
external programs to link in the compiler
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
{
possible compiler switches:
-----------------------------------------------------------------
TP to compile the compiler with Turbo or Borland Pascal
I386 generate a compiler for the Intel i386+
M68K generate a compiler for the M68000
GDB support of the GNU Debugger
EXTDEBUG some extra debug code is executed
SUPPORT_MMX only i386: releases the compiler switch
MMX which allows the compiler to generate
MMX instructions
EXTERN_MSG Don't compile the msgfiles in the compiler, always
use external messagefiles
NOAG386INT no Intel Assembler output
NOAG386NSM no NASM output
-----------------------------------------------------------------
}
{$ifdef FPC}
{ but I386 or M68K must be defined }
{ and only one of the two }
{$ifndef I386}
{$ifndef M68K}
{$fatal One of the switches I386 or M68K must be defined}
{$endif M68K}
{$endif I386}
{$ifdef I386}
{$ifdef M68K}
{$fatal ONLY one of the switches I386 or M68K must be defined}
{$endif M68K}
{$endif I386}
{$ifdef support_mmx}
{$ifndef i386}
{$fatal I386 switch must be on for MMX support}
{$endif i386}
{$endif support_mmx}
{$endif}
unit compiler;
interface
uses
{$ifdef fpc}
{$ifdef GO32V2}
emu387,
dpmiexcp,
{$endif GO32V2}
{$ifdef LINUX}
catch,
{$endif LINUX}
{$endif}
{$ifdef TP}
tpexcept,
{$endif}
dos,verbose,comphook,systems,
globals,options,parser,symtable,link,import;
function Compile(const cmd:string):longint;
implementation
var
CompilerInited : boolean;
recoverpos : jmp_buf;
procedure RecoverStop;{$ifndef FPC}far;{$endif}
begin
LongJmp(recoverpos,1);
end;
procedure DoneCompiler;
begin
if not CompilerInited then
exit;
{ Free memory }
DoneSymtable;
CompilerInited:=false;
end;
procedure InitCompiler(const cmd:string);
begin
if CompilerInited then
DoneCompiler;
{ inits which need to be done before the arguments are parsed }
get_exepath;
InitVerbose;
InitGlobals;
InitSymtable;
linker.init;
{ read the arguments }
read_arguments(cmd);
{ inits which depend on arguments }
initparser;
initimport;
CompilerInited:=true;
end;
function Compile(const cmd:string):longint;
function getrealtime : real;
var
h,m,s,s100 : word;
begin
gettime(h,m,s,s100);
getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
end;
var
starttime : real;
olddo_stop : tstopprocedure;
{$ifdef TP}
oldfreelist,
oldheapptr,
oldheaporg : pointer;
{$endif}
{$IfDef Extdebug}
EntryMemAvail : longint;
{$EndIf}
begin
{$Ifdef TP}
{ Save old heap }
oldfreelist:=freelist;
oldheapptr:=heapptr;
oldheaporg:=heaporg;
{ Create a new heap }
heaporg:=oldheapptr;
heapptr:=heaporg;
freelist:=heaporg;
{$endif}
{$ifdef EXTDEBUG}
EntryMemAvail:=MemAvail;
{$endif}
{ Initialize the compiler }
InitCompiler(cmd);
{ show some info }
Message1(general_i_compilername,FixFileName(paramstr(0)));
Message1(general_i_unitsearchpath,unitsearchpath);
Message1(general_d_sourceos,source_os.name);
Message1(general_i_targetos,target_os.name);
Message1(general_u_exepath,exepath);
Message1(general_u_gcclibpath,Linker.librarysearchpath);
{$ifdef TP}
Comment(V_Info,'Memory: '+tostr(MemAvail)+' Bytes Free');
{$endif}
olddo_stop:=do_stop;
do_stop:=recoverstop;
if setjmp(recoverpos)=0 then
begin
starttime:=getrealtime;
parser.compile(inputdir+inputfile+inputextension,false);
if status.errorcount=0 then
begin
starttime:=getrealtime-starttime;
Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(starttime))+
'.'+tostr(trunc(frac(starttime)*10)));
end;
{ Stop the compiler, frees also memory }
DoneCompiler;
end;
{ Stop is always called, so we come here when a program is compiled or not }
do_stop:=olddo_stop;
{$ifdef EXTDEBUG}
Comment(V_Info,'Memory Lost = '+tostr(EntryMemAvail-MemAvail));
{$endif EXTDEBUG}
{$Ifdef TP}
{ Restore old heap }
freelist:=oldfreelist;
heapptr:=oldheapptr;
heaporg:=oldheaporg;
{$endIf TP}
{ Set the return value if an error has occurred }
if status.errorcount=0 then
Compile:=0
else
Compile:=1;
end;
end.
{
$Log$
Revision 1.1 1998-08-10 10:18:24 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
}

250
compiler/depend
View File

@ -1,54 +1,72 @@
pp: pp.pas \
cobjects.ppu \
globals.ppu \
parser.ppu \
systems.ppu \
tree.ppu \
symtable.ppu \
options.ppu \
link.ppu \
import.ppu \
files.ppu \
verb_def.ppu \
verbose.ppu
compiler.ppu
$(COMPILER) pp.pas
cobjects.ppu: cobjects.pas
globals.ppu: globals.pas \
cobjects.ppu \
systems.ppu
cobjects.ppu: cobjects.pas
systems.ppu: systems.pas
parser.ppu: parser.pas \
systems.ppu \
cobjects.ppu \
globals.ppu \
compiler.ppu: compiler.pas \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
options.ppu \
parser.ppu \
symtable.ppu \
files.ppu \
aasm.ppu \
hcodegen.ppu \
assemble.ppu \
link.ppu \
script.ppu \
gendef.ppu \
scanner.ppu \
pbase.ppu \
pdecl.ppu \
psystem.ppu \
pmodules.ppu
import.ppu
verbose.ppu: verbose.pas \
messages.ppu \
files.ppu \
comphook.ppu \
globals.ppu
messages.ppu: messages.pas
files.ppu: files.pas \
cobjects.ppu \
globals.ppu \
ppu.ppu \
verbose.ppu \
systems.ppu
ppu.ppu: ppu.pas
comphook.ppu: comphook.pas
options.ppu: options.pas \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
scanner.ppu \
link.ppu \
messages.ppu \
gendef.ppu \
opts386.ppu
scanner.ppu: scanner.pas \
cobjects.ppu \
globals.ppu \
verbose.ppu \
comphook.ppu \
files.ppu \
systems.ppu \
symtable.ppu \
switches.ppu
symtable.ppu: symtable.pas \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
aasm.ppu \
@ -56,7 +74,8 @@ symtable.ppu: symtable.pas \
gendef.ppu \
i386.ppu \
gdb.ppu \
types.ppu
types.ppu \
ppu.ppu
aasm.ppu: aasm.pas \
cobjects.ppu \
@ -65,12 +84,6 @@ aasm.ppu: aasm.pas \
verbose.ppu \
systems.ppu
files.ppu: files.pas \
cobjects.ppu \
globals.ppu \
verbose.ppu \
systems.ppu
gendef.ppu: gendef.pas \
cobjects.ppu \
systems.ppu \
@ -95,6 +108,49 @@ types.ppu: types.pas \
verbose.ppu \
aasm.ppu
switches.ppu: switches.pas \
globals.ppu \
verbose.ppu \
files.ppu \
systems.ppu
link.ppu: link.pas \
cobjects.ppu \
script.ppu \
globals.ppu \
systems.ppu \
verbose.ppu
script.ppu: script.pas \
cobjects.ppu \
globals.ppu \
systems.ppu
opts386.ppu: opts386.pas \
options.ppu \
systems.ppu \
globals.ppu
parser.ppu: parser.pas \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
symtable.ppu \
files.ppu \
aasm.ppu \
hcodegen.ppu \
assemble.ppu \
link.ppu \
script.ppu \
gendef.ppu \
scanner.ppu \
pbase.ppu \
pdecl.ppu \
psystem.ppu \
pmodules.ppu
hcodegen.ppu: hcodegen.pas \
aasm.ppu \
tree.ppu \
@ -128,17 +184,12 @@ assemble.ppu: assemble.pas \
ag386nsm.ppu \
ag386int.ppu
script.ppu: script.pas \
cobjects.ppu \
globals.ppu \
systems.ppu
ag386att.ppu: ag386att.pas \
cobjects.ppu \
aasm.ppu \
assemble.ppu \
globals.ppu \
systems.ppu \
cobjects.ppu \
i386.ppu \
files.ppu \
verbose.ppu \
@ -166,28 +217,6 @@ ag386int.ppu: ag386int.pas \
verbose.ppu \
gdb.ppu
link.ppu: link.pas \
cobjects.ppu \
script.ppu \
globals.ppu \
systems.ppu \
verbose.ppu
scanner.ppu: scanner.pas \
cobjects.ppu \
globals.ppu \
files.ppu \
verbose.ppu \
systems.ppu \
symtable.ppu \
switches.ppu
switches.ppu: switches.pas \
globals.ppu \
verbose.ppu \
files.ppu \
systems.ppu
pbase.ppu: pbase.pas \
cobjects.ppu \
globals.ppu \
@ -220,9 +249,9 @@ pdecl.ppu: pdecl.pas \
pass_1.ppu: pass_1.pas \
tree.ppu \
scanner.ppu \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
aasm.ppu \
@ -336,8 +365,9 @@ temp_gen.ppu: temp_gen.pas \
cgi386.ppu: cgi386.pas \
tree.ppu \
verbose.ppu \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
files.ppu \
@ -377,15 +407,18 @@ cgai386.ppu: cgai386.pas \
tgeni386.ppu \
temp_gen.ppu \
hcodegen.ppu \
ppu.ppu \
gdb.ppu
cg386con.ppu: cg386con.pas \
tree.ppu \
cobjects.ppu \
verbose.ppu \
globals.ppu \
symtable.ppu \
aasm.ppu \
i386.ppu \
types.ppu \
hcodegen.ppu \
cgai386.ppu \
temp_gen.ppu \
@ -516,15 +549,37 @@ cg386flw.ppu: cg386flw.pas \
hcodegen.ppu
aopt386.ppu: aopt386.pas \
aasm.ppu \
i386.ppu \
daopt386.ppu \
popt386.ppu \
csopt386.ppu
daopt386.ppu: daopt386.pas \
aasm.ppu \
cobjects.ppu \
i386.ppu \
globals.ppu \
systems.ppu \
verbose.ppu \
hcodegen.ppu \
cgi386.ppu
popt386.ppu: popt386.pas \
aasm.ppu \
globals.ppu \
systems.ppu \
symtable.ppu \
verbose.ppu \
hcodegen.ppu \
i386.ppu \
cgi386.ppu
daopt386.ppu
csopt386.ppu: csopt386.pas \
aasm.ppu \
cobjects.ppu \
verbose.ppu \
i386.ppu \
daopt386.ppu
pstatmnt.ppu: pstatmnt.pas \
tree.ppu \
@ -539,6 +594,7 @@ pstatmnt.ppu: pstatmnt.pas \
types.ppu \
scanner.ppu \
hcodegen.ppu \
ppu.ppu \
pbase.ppu \
pexpr.ppu \
pdecl.ppu \
@ -548,7 +604,30 @@ pstatmnt.ppu: pstatmnt.pas \
ra386att.ppu \
ra386dir.ppu
ra386int.ppu: ra386int.pas
ra386int.ppu: ra386int.pas \
tree.ppu \
i386.ppu \
systems.ppu \
files.ppu \
aasm.ppu \
globals.ppu \
asmutils.ppu \
hcodegen.ppu \
scanner.ppu \
cobjects.ppu \
verbose.ppu \
types.ppu
asmutils.ppu: asmutils.pas \
symtable.ppu \
aasm.ppu \
hcodegen.ppu \
verbose.ppu \
systems.ppu \
globals.ppu \
files.ppu \
cobjects.ppu \
i386.ppu
ra386att.ppu: ra386att.pas \
i386.ppu \
@ -565,17 +644,6 @@ ra386att.ppu: ra386att.pas \
symtable.ppu \
types.ppu
asmutils.ppu: asmutils.pas \
symtable.ppu \
aasm.ppu \
hcodegen.ppu \
verbose.ppu \
systems.ppu \
globals.ppu \
files.ppu \
cobjects.ppu \
i386.ppu
ra386dir.ppu: ra386dir.pas \
tree.ppu \
files.ppu \
@ -607,6 +675,7 @@ pmodules.ppu: pmodules.pas \
files.ppu \
cobjects.ppu \
verbose.ppu \
comphook.ppu \
systems.ppu \
globals.ppu \
symtable.ppu \
@ -615,6 +684,7 @@ pmodules.ppu: pmodules.pas \
link.ppu \
assemble.ppu \
import.ppu \
ppu.ppu \
i386.ppu \
scanner.ppu \
pbase.ppu \
@ -623,25 +693,3 @@ pmodules.ppu: pmodules.pas \
psub.ppu \
parser.ppu
options.ppu: options.pas \
cobjects.ppu \
globals.ppu \
systems.ppu \
verbose.ppu \
scanner.ppu \
link.ppu \
verb_def.ppu \
messages.ppu \
gendef.ppu \
opts386.ppu
verb_def.ppu: verb_def.pas \
verbose.ppu \
globals.ppu \
files.ppu
opts386.ppu: opts386.pas \
options.ppu \
systems.ppu \
globals.ppu

8
compiler/parser.pas
View File

@ -33,7 +33,7 @@ unit parser;
implementation
uses
systems,cobjects,globals,verbose,
cobjects,verbose,comphook,systems,globals,
symtable,files,aasm,hcodegen,
assemble,link,script,gendef,
{$ifdef UseBrowser}
@ -390,7 +390,11 @@ done:
end.
{
$Log$
Revision 1.31 1998-07-14 21:46:46 peter
Revision 1.32 1998-08-10 10:18:28 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.31 1998/07/14 21:46:46 peter
* updated messages file
Revision 1.30 1998/07/14 14:46:49 peter

10
compiler/pass_1.pas
View File

@ -35,8 +35,8 @@ unit pass_1;
implementation
uses
scanner,cobjects,verbose,systems,globals,aasm,symtable,
types,strings,hcodegen,files
cobjects,verbose,comphook,systems,globals,
aasm,symtable,types,strings,hcodegen,files
{$ifdef i386}
,i386
,tgeni386
@ -5177,7 +5177,11 @@ unit pass_1;
end.
{
$Log$
Revision 1.50 1998-08-08 21:51:39 peter
Revision 1.51 1998-08-10 10:18:29 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.50 1998/08/08 21:51:39 peter
* small crash prevent is firstassignment
Revision 1.49 1998/07/30 16:07:08 florian

8
compiler/pmodules.pas
View File

@ -37,7 +37,7 @@ unit pmodules;
implementation
uses
cobjects,verbose,systems,globals,
cobjects,verbose,comphook,systems,globals,
symtable,aasm,hcodegen,
link,assemble,import
{$ifndef OLDPPU}
@ -1166,7 +1166,11 @@ unit pmodules;
end.
{
$Log$
Revision 1.36 1998-07-14 14:46:54 peter
Revision 1.37 1998-08-10 10:18:31 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.36 1998/07/14 14:46:54 peter
* released NEWINPUT
Revision 1.35 1998/07/08 12:39:38 peter

203
compiler/pp.pas
View File

@ -2,6 +2,8 @@
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Commandline compiler for Free Pascal
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
@ -27,8 +29,6 @@
GDB* support of the GNU Debugger
I386 generate a compiler for the Intel i386+
M68K generate a compiler for the M68000
MULLER release special debug code of Pierre Muller
(needs some extra units)
USEOVERLAY compiles a TP version which uses overlays
EXTDEBUG some extra debug code is executed
SUPPORT_MMX only i386: releases the compiler switch
@ -94,51 +94,20 @@ program pp;
{$ENDIF}
{$ifdef FPC}
{$UNDEF USEOVERLAY}
{$UNDEF USEPMD}
{$ENDIF}
uses
{$ifdef fpc}
{$ifdef GO32V2}
emu387,
dpmiexcp,
{$endif GO32V2}
{$endif}
{$ifdef useoverlay}
{$ifopt o+}
Overlay,ppovin,
{$else}
{$error You must compile with the $O+ switch}
{$error You must compile with the $O+ switch}
{$endif}
{$endif useoverlay}
{$ifdef lock}
lock,
{$endif lock}
{$ifdef profile}
profile,
{$endif profile}
{$ifdef muller}
openfile,
{$ifdef usepmd}
usepmd,
{$endif usepmd}
{$endif}
{$ifdef LINUX}
catch,
{$endif LINUX}
{$IfDef PMD}
OpenFile,
BBError,
ObjMemory,
PMD, MemCheck,
{$EndIf}
{$ifdef TP}
objects,
{$endif}
dos,cobjects,
globals,parser,systems,tree,symtable,options,link,import,files,
verb_def,verbose;
globals,compiler;
{$ifdef useoverlay}
{$O files}
@ -165,7 +134,7 @@ uses
{$O script}
{$O switches}
{$O temp_gen}
{$O verb_def}
{$O comphook}
{$O dos}
{$O scanner}
{$O symtable}
@ -226,26 +195,12 @@ uses
{$endif}
{$endif useoverlay}
function getrealtime : real;
var
h,m,s,s100 : word;
begin
dos.gettime(h,m,s,s100);
getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
end;
var
oldexit : pointer;
procedure myexit;{$ifndef FPC}far;{$endif}
begin
exitproc:=oldexit;
{$ifdef tp}
if use_big then
symbolstream.done;
{$endif}
{ Show Runtime error if there was an error }
if (erroraddr<>nil) then
begin
case exitcode of
@ -258,64 +213,10 @@ begin
Writeln('Error: Out of memory');
end;
end;
{when the module is assigned, then the messagefile is also loaded}
Writeln('Compilation aborted at line ',aktfilepos.line);
end;
end;
{$ifdef tp}
procedure do_streamerror;
begin
if symbolstream.status=-2 then
WriteLn('Error: Not enough EMS memory')
else
WriteLn('Error: EMS Error ',symbolstream.status);
{$ifndef MULLER}
halt(1);
{$else MULLER}
runerror(190);
{$endif MULLER}
end;
{$ifdef USEOVERLAY}
function _heaperror(size:word):integer;far;
type
heaprecord=record
next:pointer;
values:longint;
end;
var
l,m:longint;
begin
l:=ovrgetbuf-ovrminsize;
if (size>maxavail) and (l>=size) then
begin
m:=((longint(size)+$3fff) and $ffffc000);
{Clear the overlay buffer.}
ovrclearbuf;
{Shrink it.}
ovrheapend:=ovrheapend-m shr 4;
heaprecord(ptr(ovrheapend,0)^).next:=freelist;
heaprecord(ptr(ovrheapend,0)^).values:=m shl 12;
heaporg:=ptr(ovrheapend,0);
freelist:=heaporg;
Writeln('Warning: Overlay buffer shrinked, because of memory shortage');
_heaperror:=2;
end
else
_heaperror:=0;
end;
{$endif USEOVERLAY}
{$endif TP}
var
start : real;
{$IfDef Extdebug}
EntryMemAvail : longint;
{$EndIf}
begin
oldexit:=exitproc;
exitproc:=@myexit;
@ -326,91 +227,29 @@ begin
heapblocks:=true;
{$endif}
{$endif}
{$ifdef EXTDEBUG}
EntryMemAvail:=MemAvail;
{$endif}
{$ifdef MULLER}
{$ifdef DPMI}
HeapBlock:=$ff00;
{$endif DPMI}
{$endif MULLER}
{$ifdef TP}
{$IFDEF USEOVERLAY}
heaperror:=@_heaperror;
{$ENDIF USEOVERLAY}
if use_big then
begin
streamerror:=@do_streamerror;
{ symbolstream.init('TMPFILE',stcreate,16000); }
{$ifndef dpmi}
symbolstream.init(10000,4000000); {using ems streams}
{$else}
symbolstream.init(1000000,16000); {using memory streams}
{$endif}
if symbolstream.errorinfo=stiniterror then
do_streamerror;
{ write something, because pos 0 means nil pointer }
symbolstream.writestr(@inputfile);
end;
{$endif tp}
{ inits which need to be done before the arguments are parsed }
get_exepath;
init_tree;
globalsinit;
init_symtable;
linker.init;
{ read the arguments }
read_arguments;
{ inits which depend on arguments }
initparser;
initimport;
{show some info}
Message1(general_i_compilername,FixFileName(paramstr(0)));
Message1(general_i_unitsearchpath,unitsearchpath);
Message1(general_d_sourceos,source_os.name);
Message1(general_i_targetos,target_os.name);
Message1(general_u_exepath,exepath);
{$ifdef linux}
Message1(general_u_gcclibpath,Linker.librarysearchpath);
{$endif}
{$ifdef TP}
Comment(V_Info,'Memory: '+tostr(MemAvail)+' Bytes Free');
{$ifdef UseOverlay}
InitOverlay;
{$endif}
start:=getrealtime;
compile(inputdir+inputfile+inputextension,false);
if status.errorcount=0 then
begin
start:=getrealtime-start;
Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(start))+'.'+tostr(trunc(frac(start)*10)));
end;
done_symtable;
{$ifdef TP}
Comment(V_Info,'Memory: '+tostr(MemAvail)+' Bytes Free');
{$endif}
{$ifdef EXTDEBUG}
Comment(V_Info,'Memory lost = '+tostr(EntryMemAvail-MemAvail));
{$endif EXTDEBUG}
{ exits with error 1 if no codegeneration }
if status.errorcount=0 then
halt(0)
else
halt(1);
{ Call the compiler with empty command, so it will take the parameters }
Halt(Compile(''));
end.
{
$Log$
Revision 1.23 1998-08-05 16:00:16 florian
Revision 1.24 1998-08-10 10:18:32 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.23 1998/08/05 16:00:16 florian
* some fixes for ansi strings
* $log$ to $Log$ changed
* $log$ to $Log$
* $log$ to Revision 1.24 1998-08-10 10:18:32 peter
* $log$ to + Compiler,Comphook unit which are the new interface units to the
* $log$ to compiler
* $log$ to changed
Revision 1.22 1998/08/04 16:28:40 jonas
* added support for NoRa386* in the {$O ...} section
* added support for NoRa386* in the $O ... section
Revision 1.21 1998/07/18 17:11:12 florian
+ ansi string constants fixed

92
compiler/ppovin.pas
View File

@ -24,50 +24,72 @@ unit ppovin;
interface
var ovrminsize:longint;
var
ovrminsize:longint;
procedure InitOverlay;
implementation
uses overlay;
uses overlay;
var s:string;
function _heaperror(size:word):integer;far;
type
heaprecord=record
next:pointer;
values:longint;
end;
var
l,m:longint;
begin
s:=paramstr(0);
ovrinit(copy(s,1,length(s)-3)+'ovr');
if ovrresult=ovrok then
begin
{May fail if no EMS memory is available. No need for error
checking, though, as the overlay manager happily runs without
EMS.}
ovrinitEMS;
ovrminsize:=ovrgetbuf;
ovrsetbuf(ovrminsize+$20000);
end
else
runerror($da);
l:=ovrgetbuf-ovrminsize;
if (size>maxavail) and (l>=size) then
begin
m:=((longint(size)+$3fff) and $ffffc000);
{Clear the overlay buffer.}
ovrclearbuf;
{Shrink it.}
ovrheapend:=ovrheapend-m shr 4;
heaprecord(ptr(ovrheapend,0)^).next:=freelist;
heaprecord(ptr(ovrheapend,0)^).values:=m shl 12;
heaporg:=ptr(ovrheapend,0);
freelist:=heaporg;
Writeln('Warning: Overlay buffer shrinked, because of memory shortage');
_heaperror:=2;
end
else
_heaperror:=0;
end;
procedure InitOverlay;
begin
heaperror:=@_heaperror;
end;
var
s:string;
begin
s:=paramstr(0);
ovrinit(copy(s,1,length(s)-3)+'ovr');
if ovrresult=ovrok then
begin
{May fail if no EMS memory is available. No need for error
checking, though, as the overlay manager happily runs without
EMS.}
ovrinitEMS;
ovrminsize:=ovrgetbuf;
ovrsetbuf(ovrminsize+$20000);
end
else
runerror($da);
end.
{
$Log$
Revision 1.1 1998-03-25 11:18:15 root
Initial revision
Revision 1.2 1998-08-10 10:18:33 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.5 1998/03/10 01:17:24 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Pre CVS Log:
FK Florian Klaempfl
DM Dani‰l Mantione
+ feature added
- removed
* bug fixed or changed
12th October 1997:
Rewritten (DM).
}

25
compiler/scanner.pas
View File

@ -28,7 +28,7 @@ unit scanner;
interface
uses
cobjects,globals,verbose,files;
cobjects,globals,verbose,comphook,files;
const
{$ifdef TP}
@ -510,11 +510,13 @@ implementation
if closed then
exit;
repeat
{ still more to read, then we have an illegal char }
{ still more to read?, then change the #0 to a space so its seen
as a seperator }
if (bufsize>0) and (inputpointer-inputbuffer<bufsize) then
begin
gettokenpos;
Message(scan_f_illegal_char);
c:=' ';
inc(longint(inputpointer));
exit;
end;
{ can we read more from this file ? }
if filenotatend then
@ -561,7 +563,7 @@ implementation
begin
lasttokenpos:=bufstart+(inputpointer-inputbuffer);
tokenpos.line:=line_no;
tokenpos.column:=lasttokenpos-lastlinepos+1;
tokenpos.column:=lasttokenpos-lastlinepos;
tokenpos.fileindex:=current_module^.current_index;
aktfilepos:=tokenpos;
end;
@ -627,10 +629,10 @@ implementation
end;
plongint(longint(linebuf)+line_no*2)^:=lastlinepos;
{$endif SourceLine}
{ update for status }
{ update for status and call the show status routine }
aktfilepos.line:=line_no; { update for v_status }
inc(status.compiledlines);
Comment(V_Status,'');
ShowStatus;
end;
@ -729,10 +731,8 @@ implementation
c:=inputpointer^;
inc(longint(inputpointer));
end;
#0 : reload;
#13,#10 : begin
linebreak;
break;
end;
@ -740,7 +740,6 @@ implementation
break;
end;
until false;
orgpattern[0]:=chr(i);
pattern[0]:=chr(i);
end;
@ -1549,7 +1548,11 @@ exit_label:
end.
{
$Log$
Revision 1.37 1998-07-23 12:40:41 michael
Revision 1.38 1998-08-10 10:18:34 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.37 1998/07/23 12:40:41 michael
No nested comments in Delphi mode.
Revision 1.36 1998/07/20 22:17:17 florian

16
compiler/symsym.inc
View File

@ -467,24 +467,26 @@
var
pd : pprocdef;
oldaktfilepos : tfileposinfo;
begin
pd:=definition;
while assigned(pd) do
begin
if pd^.forwarddef then
begin
{$ifdef GDB}
oldaktfilepos:=aktfilepos;
aktfilepos:=fileinfo;
if assigned(pd^._class) then
Message1(sym_e_forward_not_resolved,pd^._class^.name^+'.'+name+demangledparas(pd^.demangled_paras))
else
{$endif GDB}
Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras)
Message1(sym_e_forward_not_resolved,name+pd^.demangled_paras);
aktfilepos:=oldaktfilepos;
end;
pd:=pd^.nextoverloaded;
end;
end;
procedure tprocsym.deref;
var t : ttoken;
last : pprocdef;
@ -1650,7 +1652,11 @@
{
$Log$
Revision 1.25 1998-07-30 11:18:19 florian
Revision 1.26 1998-08-10 10:18:35 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.25 1998/07/30 11:18:19 florian
+ first implementation of try ... except on .. do end;
* limitiation of 65535 bytes parameters for cdecl removed

336
compiler/tpexcept.pas Normal file
View File

@ -0,0 +1,336 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
SetJmp and LongJmp implementation for recovery handling of the
compiler
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
unit tpexcept;
interface
{$S-}
type
jmp_buf = record
{$ifdef TP}
_ax,_bx,_cx,_dx,_si,_di,_bp,_sp,_ip,flags : word;
_cs,_ds,_es,_ss : word;
{$else}
eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
cs,ds,es,fs,gs,ss : word;
{$endif TP}
end;
{$ifdef TP}
function setjmp(var rec : jmp_buf) : integer;
procedure longjmp(const rec : jmp_buf;return_value : integer);
{$else}
function setjmp(var rec : jmp_buf) : longint;
procedure longjmp(const rec : jmp_buf;return_value : longint);
{$endif TP}
implementation
{*****************************************************************************
Exception Helpers
*****************************************************************************}
{$ifdef TP}
function setjmp(var rec : jmp_buf) : integer;
begin
asm
push di
push es
les di,rec
mov es:[di].jmp_buf._ax,ax
mov es:[di].jmp_buf._bx,bx
mov es:[di].jmp_buf._cx,cx
mov es:[di].jmp_buf._dx,dx
mov es:[di].jmp_buf._si,si
{ load di }
mov ax,[bp-4]
{ ... and store it }
mov es:[di].jmp_buf._di,ax
{ load es }
mov ax,[bp-6]
{ ... and store it }
mov es:[di].jmp_buf._es,ax
{ bp ... }
mov ax,[bp]
mov es:[di].jmp_buf._bp,ax
{ sp ... }
mov ax,bp
add ax,10
mov es:[di].jmp_buf._sp,ax
{ the return address }
mov ax,[bp+2]
mov es:[di].jmp_buf._ip,ax
mov ax,[bp+4]
mov es:[di].jmp_buf._cs,ax
{ flags ... }
pushf
pop word ptr es:[di].jmp_buf.flags
mov es:[di].jmp_buf._ds,ds
mov es:[di].jmp_buf._ss,ss
{ restore es:di }
pop es
pop di
{ we come from the initial call }
xor ax,ax
leave
retf 4
end;
end;
procedure longjmp(const rec : jmp_buf;return_value : integer);
begin
asm
{ this is the address of rec }
lds di,rec
{ save return value }
mov ax,return_value
mov ds:[di].jmp_buf._ax,ax
{ restore compiler shit }
pop bp
{ restore some registers }
mov bx,ds:[di].jmp_buf._bx
mov cx,ds:[di].jmp_buf._cx
mov dx,ds:[di].jmp_buf._dx
mov bp,ds:[di].jmp_buf._bp
{ create a stack frame for the return }
mov es,ds:[di].jmp_buf._ss
mov si,ds:[di].jmp_buf._sp
sub si,12
{ store ds }
mov ax,ds:[di].jmp_buf._ds
mov es:[si],ax
{ store di }
mov ax,ds:[di].jmp_buf._di
mov es:[si+2],ax
{ store si }
mov ax,ds:[di].jmp_buf._si
mov es:[si+4],ax
{ store flags }
mov ax,ds:[di].jmp_buf.flags
mov es:[si+6],ax
{ store ip }
mov ax,ds:[di].jmp_buf._ip
mov es:[si+8],ax
{ store cs }
mov ax,ds:[di].jmp_buf._cs
mov es:[si+10],ax
{ load stack }
mov ax,es
mov ss,ax
mov sp,si
{ load return value }
mov ax,ds:[di].jmp_buf._ax
{ load old ES }
mov es,ds:[di].jmp_buf._es
pop ds
pop di
pop si
popf
retf
end;
end;
{$else}
function setjmp(var rec : jmp_buf) : longint;
begin
asm
pushl %edi
movl rec,%edi
movl %eax,(%edi)
movl %ebx,4(%edi)
movl %ecx,8(%edi)
movl %edx,12(%edi)
movl %esi,16(%edi)
{ load edi }
movl -4(%ebp),%eax
{ ... and store it }
movl %eax,20(%edi)
{ ebp ... }
movl (%ebp),%eax
movl %eax,24(%edi)
{ esp ... }
movl %esp,%eax
addl $12,%eax
movl %eax,28(%edi)
{ the return address }
movl 4(%ebp),%eax
movl %eax,32(%edi)
{ flags ... }
pushfl
popl 36(%edi)
{ !!!!! the segment registers, not yet needed }
{ you need them if the exception comes from
an interrupt or a seg_move }
movw %cs,40(%edi)
movw %ds,42(%edi)
movw %es,44(%edi)
movw %fs,46(%edi)
movw %gs,48(%edi)
movw %ss,50(%edi)
{ restore EDI }
pop %edi
{ we come from the initial call }
xorl %eax,%eax
leave
ret $4
end;
end;
procedure longjmp(const rec : jmp_buf;return_value : longint);
begin
asm
{ restore compiler shit }
popl %ebp
{ this is the address of rec }
movl 4(%esp),%edi
{ save return value }
movl 8(%esp),%eax
movl %eax,0(%edi)
{ !!!!! load segment registers }
movw 46(%edi),%fs
movw 48(%edi),%gs
{ ... and some other registers }
movl 4(%edi),%ebx
movl 8(%edi),%ecx
movl 12(%edi),%edx
movl 24(%edi),%ebp
{ !!!!! movw 50(%edi),%es }
movl 28(%edi),%esi
{ create a stack frame for the return }
subl $16,%esi
{
movzwl 42(%edi),%eax
!!!!! es
movl %eax,(%esi)
}
{ edi }
movl 20(%edi),%eax
{ !!!!! es }
movl %eax,(%esi)
{ esi }
movl 16(%edi),%eax
{ !!!!! es }
movl %eax,4(%esi)
{ eip }
movl 32(%edi),%eax
{ !!!!! es }
movl %eax,12(%esi)
{ !!!!! cs
movl 40(%edi),%eax
es
movl %eax,16(%esi)
}
{ load and store flags }
movl 36(%edi),%eax
{ !!!!!
es
}
movl %eax,8(%esi)
{ load return value }
movl 0(%edi),%eax
{ load old ES
!!!!! movw 44(%edi),%es
}
{ load stack
!!!!! movw 50(%edi),%ss }
movl %esi,%esp
{ !!!!
popl %ds
}
popl %edi
popl %esi
popfl
ret
end;
end;
{$endif TP}
end.
{
$Log$
Revision 1.1 1998-08-10 10:18:36 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
}

251
compiler/verb_def.pas
View File

@ -1,251 +0,0 @@
{
$Id$
Copyright (c) 1998 by Peter Vreman
This unit handles the default verbose routines
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit verb_def;
interface
procedure SetRedirectFile(const fn:string);
procedure _stop;
Function _comment(Level:Longint;const s:string):boolean;
function _internalerror(i : longint) : boolean;
implementation
uses
verbose,globals,
strings,dos;
const
{ RHIDE expect gcc like error output }
rh_errorstr='error: ';
rh_warningstr='warning: ';
fatalstr='Fatal: ';
errorstr='Error: ';
warningstr='Warning: ';
notestr='Note: ';
hintstr='Hint: ';
var
redirexitsave : pointer;
redirtext : boolean;
redirfile : text;
{****************************************************************************
Extra Handlers for default compiler
****************************************************************************}
procedure DoneRedirectFile;{$ifndef FPC}far;{$ENDIF}
begin
exitproc:=redirexitsave;
if redirtext then
close(redirfile);
end;
procedure SetRedirectFile(const fn:string);
begin
assign(redirfile,fn);
{$I-}
rewrite(redirfile);
{$I+}
redirtext:=(ioresult=0);
if redirtext then
begin
redirexitsave:=exitproc;
exitproc:=@DoneRedirectFile;
end;
end;
{****************************************************************************
Predefined default Handlers
****************************************************************************}
{ predefined handler to stop the compiler }
procedure _stop;
begin
halt(1);
end;
Function _comment(Level:Longint;const s:string):boolean;
var
hs : string;
begin
_comment:=false; { never stop }
if (verbosity and Level)=Level then
begin
{ Status info?, Called every line }
if ((Level and V_Status)<>0) and (s='') then
begin
if (status.compiledlines=1) then
WriteLn(memavail shr 10,' Kb Free');
if (status.currentline>0) and (status.currentline mod 100=0) then
{$ifdef FPC}
WriteLn(status.currentline,' ',memavail shr 10,'/',system.heapsize shr 10,' Kb Free');
{$else}
WriteLn(status.currentline,' ',memavail shr 10,' Kb Free');
{$endif}
end
else
{ Message }
begin
hs:='';
if not(use_rhide) then
begin
if (verbosity and Level)=V_Hint then
hs:=hintstr;
if (verbosity and Level)=V_Note then
hs:=notestr;
if (verbosity and Level)=V_Warning then
hs:=warningstr;
if (verbosity and Level)=V_Error then
hs:=errorstr;
if (verbosity and Level)=V_Fatal then
hs:=fatalstr;
end
else
begin
if (verbosity and Level)=V_Hint then
hs:=rh_warningstr;
if (verbosity and Level)=V_Note then
hs:=rh_warningstr;
if (verbosity and Level)=V_Warning then
hs:=rh_warningstr;
if (verbosity and Level)=V_Error then
hs:=rh_errorstr;
if (verbosity and Level)=V_Fatal then
hs:=rh_errorstr;
end;
if (Level<=V_ShowFile) and (status.currentline>0) then
begin
{ Adding the column should not confuse RHIDE,
even if it does not yet use it PM }
if Use_Rhide then
hs:=lower(bstoslash(status.currentsource))+':'+tostr(status.currentline)
+':'+tostr(status.currentcolumn)+': '+hs
else
hs:=status.currentsource+'('+tostr(status.currentline)
+','+tostr(status.currentcolumn)+') '+hs;
end;
{ add the message to the text }
hs:=hs+s;
{$ifdef FPC}
if UseStdErr then
begin
writeln(stderr,hs);
flush(stderr);
end
else
{$endif}
begin
if redirtext then
writeln(redirfile,hs)
else
writeln(hs);
end;
end;
end;
end;
function _internalerror(i : longint) : boolean;
begin
_comment(V_Fatal,'Internal error '+tostr(i));
_internalerror:=true;
end;
begin
{$ifdef FPC}
do_stop:=@_stop;
do_comment:=@_comment;
do_internalerror:=@_internalerror;
{$else}
do_stop:=_stop;
do_comment:=_comment;
do_internalerror:=_internalerror;
{$endif}
end.
{
$Log$
Revision 1.14 1998-08-04 13:22:48 pierre
* weird bug fixed :
a pchar ' ' (simple space or any other letter) was found to
be equal to a string of length zero !!!
thus printing out non sense
found that out while checking Control-C !!
+ added column info also in RHIDE format as
it might be usefull later
Revision 1.13 1998/07/14 14:47:12 peter
* released NEWINPUT
Revision 1.12 1998/07/07 11:20:19 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.11 1998/06/19 15:40:00 peter
* bp7 fix
Revision 1.10 1998/06/16 11:32:19 peter
* small cosmetic fixes
Revision 1.9 1998/05/23 01:21:33 peter
+ aktasmmode, aktoptprocessor, aktoutputformat
+ smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+ $LIBNAME to set the library name where the unit will be put in
* splitted cgi386 a bit (codeseg to large for bp7)
* nasm, tasm works again. nasm moved to ag386nsm.pas
Revision 1.8 1998/05/21 19:33:38 peter
+ better procedure directive handling and only one table
Revision 1.7 1998/05/12 10:47:01 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
* fixed some messages
* first time parameter scan is only for -v and -T
- removed old style messages
Revision 1.6 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
* no findfirst/findnext anymore to remove smartlink *.o files
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
* fixed one remaining bug in scanner for line counts
* several little fixes
Revision 1.4 1998/04/29 10:34:09 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
}

177
compiler/verbose.pas
View File

@ -32,7 +32,6 @@ uses messages;
{$i msgidx.inc}
Const
MaxErrorCount : longint = 50;
{ <$10000 will show file and line }
V_Fatal = $0;
V_Error = $1;
@ -53,59 +52,60 @@ Const
V_All = $ffffffff;
V_Default = V_Fatal + V_Error + V_Normal;
Verbosity : longint=V_Default;
type
TCompileStatus = record
currentmodule,
currentsource : string; { filename }
currentline,
currentcolumn : longint; { current line and column }
compiledlines : longint; { the number of lines which are compiled }
errorcount : longint; { number of generated errors }
end;
var
status : tcompilestatus;
msg : pmessage;
UseStdErr,
Use_Rhide : boolean;
lastfileidx,
lastmoduleidx : longint;
procedure LoadMsgFile(const fn:string);
procedure SetRedirectFile(const fn:string);
function SetVerbosity(const s:string):boolean;
procedure stop;
procedure comment(l:longint;const s:string);
procedure internalerror(i:longint);
procedure LoadMsgFile(const fn:string);
procedure Stop;
procedure ShowStatus;
procedure Internalerror(i:longint);
procedure Comment(l:longint;const s:string);
procedure Message(w:tmsgconst);
procedure Message1(w:tmsgconst;const s1:string);
procedure Message2(w:tmsgconst;const s1,s2:string);
procedure Message3(w:tmsgconst;const s1,s2,s3:string);
{ Function redirecting for IDE support }
type
tstopprocedure = procedure;
tcommentfunction = function(Level:Longint;const s:string):boolean;
tinternalerrorfunction = function(i:longint):boolean;
var
do_stop : tstopprocedure;
do_comment : tcommentfunction;
do_internalerror : tinternalerrorfunction;
procedure InitVerbose;
implementation
uses
files,
files,comphook,
globals;
procedure LoadMsgFile(const fn:string);
var
redirexitsave : pointer;
{****************************************************************************
Extra Handlers for default compiler
****************************************************************************}
procedure DoneRedirectFile;{$ifndef FPC}far;{$ENDIF}
begin
if not (msg=nil) then
dispose(msg,Done);
msg:=new(pmessage,InitExtern(fn,ord(endmsgconst)));
exitproc:=redirexitsave;
if status.use_redir then
close(status.redirfile);
end;
procedure SetRedirectFile(const fn:string);
begin
assign(status.redirfile,fn);
{$I-}
rewrite(status.redirfile);
{$I+}
status.use_redir:=(ioresult=0);
if status.use_redir then
begin
redirexitsave:=exitproc;
exitproc:=@DoneRedirectFile;
end;
end;
@ -116,10 +116,10 @@ var
inverse : boolean;
c : char;
begin
setverbosity:=false;
Setverbosity:=false;
val(s,m,i);
if (i=0) and (s<>'') then
verbosity:=m
status.verbosity:=m
else
begin
for i:=1 to length(s) do
@ -134,78 +134,86 @@ begin
inverse:=false;
case upcase(s[i]) of
{ Special cases }
'A' : Verbosity:=V_All;
'0' : Verbosity:=V_Default;
'A' : status.verbosity:=V_All;
'0' : status.verbosity:=V_Default;
'R' : begin
if inverse then
begin
Use_rhide:=false;
UseStdErr:=false;
status.use_gccoutput:=false;
status.use_stderr:=false;
end
else
begin
Use_rhide:=true;
UseStdErr:=true;
status.use_gccoutput:=true;
status.use_stderr:=true;
end;
end;
{ Normal cases - do an or }
'E' : if inverse then
Verbosity:=Verbosity and (not V_Error)
status.verbosity:=status.verbosity and (not V_Error)
else
Verbosity:=Verbosity or V_Error;
status.verbosity:=status.verbosity or V_Error;
'I' : if inverse then
Verbosity:=Verbosity and (not V_Info)
status.verbosity:=status.verbosity and (not V_Info)
else
Verbosity:=Verbosity or V_Info;
status.verbosity:=status.verbosity or V_Info;
'W' : if inverse then
Verbosity:=Verbosity and (not V_Warning)
status.verbosity:=status.verbosity and (not V_Warning)
else
Verbosity:=Verbosity or V_Warning;
status.verbosity:=status.verbosity or V_Warning;
'N' : if inverse then
Verbosity:=Verbosity and (not V_Note)
status.verbosity:=status.verbosity and (not V_Note)
else
Verbosity:=Verbosity or V_Note;
status.verbosity:=status.verbosity or V_Note;
'H' : if inverse then
Verbosity:=Verbosity and (not V_Hint)
status.verbosity:=status.verbosity and (not V_Hint)
else
Verbosity:=Verbosity or V_Hint;
status.verbosity:=status.verbosity or V_Hint;
'L' : if inverse then
Verbosity:=Verbosity and (not V_Status)
status.verbosity:=status.verbosity and (not V_Status)
else
Verbosity:=Verbosity or V_Status;
status.verbosity:=status.verbosity or V_Status;
'U' : if inverse then
Verbosity:=Verbosity and (not V_Used)
status.verbosity:=status.verbosity and (not V_Used)
else
Verbosity:=Verbosity or V_Used;
status.verbosity:=status.verbosity or V_Used;
'T' : if inverse then
Verbosity:=Verbosity and (not V_Tried)
status.verbosity:=status.verbosity and (not V_Tried)
else
Verbosity:=Verbosity or V_Tried;
status.verbosity:=status.verbosity or V_Tried;
'M' : if inverse then
Verbosity:=Verbosity and (not V_Macro)
status.verbosity:=status.verbosity and (not V_Macro)
else
Verbosity:=Verbosity or V_Macro;
status.verbosity:=status.verbosity or V_Macro;
'P' : if inverse then
Verbosity:=Verbosity and (not V_Procedure)
status.verbosity:=status.verbosity and (not V_Procedure)
else
Verbosity:=Verbosity or V_Procedure;
status.verbosity:=status.verbosity or V_Procedure;
'C' : if inverse then
Verbosity:=Verbosity and (not V_Conditional)
status.verbosity:=status.verbosity and (not V_Conditional)
else
Verbosity:=Verbosity or V_Conditional;
status.verbosity:=status.verbosity or V_Conditional;
'D' : if inverse then
Verbosity:=Verbosity and (not V_Debug)
status.verbosity:=status.verbosity and (not V_Debug)
else
Verbosity:=Verbosity or V_Debug;
status.verbosity:=status.verbosity or V_Debug;
end;
end;
end;
if Verbosity=0 then
Verbosity:=V_Default;
if status.verbosity=0 then
status.verbosity:=V_Default;
setverbosity:=true;
end;
procedure LoadMsgFile(const fn:string);
begin
if not (msg=nil) then
dispose(msg,Done);
msg:=new(pmessage,InitExtern(fn,ord(endmsgconst)));
end;
procedure stop;
begin
{$ifndef TP}
@ -216,6 +224,18 @@ begin
end;
procedure ShowStatus;
begin
{$ifndef TP}
if do_status() then
stop;
{$else}
if do_status then
stop;
{$endif}
end;
procedure internalerror(i : longint);
begin
do_internalerror(i);
@ -242,7 +262,7 @@ begin
lastfileidx:=current_module^.current_index;
end;
{ show comment }
if do_comment(l,s) or dostop or (status.errorcount>=maxerrorcount) then
if do_comment(l,s) or dostop or (status.errorcount>=status.maxerrorcount) then
stop
end;
@ -267,6 +287,7 @@ begin
case upcase(s[i]) of
'F' : begin
v:=v or V_Fatal;
inc(status.errorcount);
dostop:=true;
end;
'E' : begin
@ -305,7 +326,7 @@ begin
lastfileidx:=current_module^.current_index;
end;
{ show comment }
if do_comment(v,s) or dostop or (status.errorcount>=maxerrorcount) then
if do_comment(v,s) or dostop or (status.errorcount>=status.maxerrorcount) then
stop;
end;
@ -334,6 +355,14 @@ begin
end;
procedure InitVerbose;
begin
{ Init }
FillChar(Status,sizeof(TCompilerStatus),0);
status.verbosity:=V_Default;
Status.MaxErrorCount:=50;
end;
begin
{$IFNDEF EXTERN_MSG}
msg:=new(pmessage,Init(@msgtxt,ord(endmsgconst)));
@ -342,7 +371,11 @@ end.
{
$Log$
Revision 1.11 1998-07-14 14:47:13 peter
Revision 1.12 1998-08-10 10:18:37 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.11 1998/07/14 14:47:13 peter
* released NEWINPUT
Revision 1.10 1998/07/07 12:32:56 peter