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

    compiler

compiler/cgi386.pas

@@ -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 :)
 

compiler/comphook.pas

@@ -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
+}

compiler/compiler.pas

@@ -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
+
+}

compiler/depend

@@ -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 \
+compiler.ppu: compiler.pas \
+	verbose.ppu \
+	comphook.ppu \
 	systems.ppu \
-	cobjects.ppu \
 	globals.ppu \
-	verbose.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,16 +549,38 @@ 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 \
-	symtable.ppu \
 	verbose.ppu \
 	hcodegen.ppu \
-	i386.ppu \
 	cgi386.ppu
 
+popt386.ppu: popt386.pas \
+	aasm.ppu \
+	globals.ppu \
+	systems.ppu \
+	verbose.ppu \
+	hcodegen.ppu \
+	i386.ppu \
+	daopt386.ppu
+
+csopt386.ppu: csopt386.pas \
+	aasm.ppu \
+	cobjects.ppu \
+	verbose.ppu \
+	i386.ppu \
+	daopt386.ppu
+
 pstatmnt.ppu: pstatmnt.pas \
 	tree.ppu \
 	cobjects.ppu \
@@ -539,6 +594,7 @@ pstatmnt.ppu: pstatmnt.pas \
 	types.ppu \
 	scanner.ppu \
 	hcodegen.ppu \
+	ppu.ppu \
 	pbase.ppu \
 	pexpr.ppu \
 	pdecl.ppu \
@@ -548,21 +604,18 @@ pstatmnt.ppu: pstatmnt.pas \
 	ra386att.ppu \
 	ra386dir.ppu
 
-ra386int.ppu: ra386int.pas
-
-ra386att.ppu: ra386att.pas \
-	i386.ppu \
+ra386int.ppu: ra386int.pas \
 	tree.ppu \
+	i386.ppu \
+	systems.ppu \
 	files.ppu \
 	aasm.ppu \
 	globals.ppu \
 	asmutils.ppu \
 	hcodegen.ppu \
 	scanner.ppu \
-	systems.ppu \
 	cobjects.ppu \
 	verbose.ppu \
-	symtable.ppu \
 	types.ppu
 
 asmutils.ppu: asmutils.pas \
@@ -576,6 +629,21 @@ asmutils.ppu: asmutils.pas \
 	cobjects.ppu \
 	i386.ppu
 
+ra386att.ppu: ra386att.pas \
+	i386.ppu \
+	tree.ppu \
+	files.ppu \
+	aasm.ppu \
+	globals.ppu \
+	asmutils.ppu \
+	hcodegen.ppu \
+	scanner.ppu \
+	systems.ppu \
+	cobjects.ppu \
+	verbose.ppu \
+	symtable.ppu \
+	types.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
-

compiler/parser.pas

@@ -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

compiler/pass_1.pas

@@ -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

compiler/pmodules.pas

@@ -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

compiler/pp.pas

@@ -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);
+{$ifdef UseOverlay}
+  InitOverlay;
 {$endif}
-{$ifdef TP}
-   Comment(V_Info,'Memory: '+tostr(MemAvail)+' Bytes Free');
-{$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

compiler/ppovin.pas

@@ -24,50 +24,72 @@ unit ppovin;
 
 interface
 
-var ovrminsize:longint;
+var
+  ovrminsize:longint;
+
+procedure InitOverlay;
 
 implementation
+uses overlay;
+
 
-uses    overlay;
+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;
+
+procedure InitOverlay;
+begin
+  heaperror:=@_heaperror;
+end;
 
-var s:string;
 
+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);
+  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.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
+  Revision 1.2  1998-08-10 10:18:33  peter
+    + Compiler,Comphook unit which are the new interface units to the
+      compiler
 
-  12th October 1997:
-        Rewritten (DM).
 }
 
 

compiler/scanner.pas

@@ -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

compiler/symsym.inc

@@ -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
 

compiler/tpexcept.pas

@@ -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
+
+}
+

compiler/verb_def.pas

@@ -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
-}

compiler/verbose.pas

@@ -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