Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/549b.lha/M2P_v1.0_sources/source.lzh/DBug.mpp

Modula Implementation | 1991-08-10 | 9.6 KB | 303 lines

IMPLEMENTATION MODULE DBug;

@IF AMIGA THEN

   @INCLUDE "MACROS"

   IMPORT SYSTEM;
   IMPORT Tasks;

   @IF    M2S THEN
      IMPORT RunTime;
   @ELSIF TDI THEN
      IMPORT AMIGAX;
      IMPORT Libraries;
   @END

   (*----------------------------------------------------------------------*)

   @IF    M2S THEN CONST HaltNumber = 0;
   @ELSIF TDI THEN CONST HaltNumber = 9;
   @ELSE           CONST HaltNumber = 0;
   @END

   TYPE Message = ARRAY [0..40] OF CHAR;

   VAR errorNo      : INTEGER;       (* Error number *)
       errorText    : POINTER TO Message;

       task         : Tasks.TaskPtr;
       oldTrapCode  : PROC;

   @IF TDI THEN
   VAR IntuitionBase: SYSTEM.ADDRESS;
   @END

   (*----------------------------------------------------------------------*)
   (* To avoid importing Intuition, we simply define AutoRequest here      *)
   (*----------------------------------------------------------------------*)

   @NoLongAddressing

   @IF M2S THEN

      PROCEDURE AutoRequest(window,bodyText,posText,negText:SYSTEM.ADDRESS;
                            posFlags,negFlags:LONGBITSET;
                            width,height:INTEGER): BOOLEAN;
      INLINE(RunTime.IntuitionBase, -348, 8, 9, 10, 11, 0, 1, 2, 3);

   @ELSIF TDI THEN

      @NoEntryExitCode

      PROCEDURE AutoRequest(window,bodyText,posText,negText:SYSTEM.ADDRESS;
                            posFlags,negFlags:LONGBITSET;
                            width,height:LONGINT): BOOLEAN;
      BEGIN
         SYSTEM.CODE(048E7H,070FEH);            (* movem.l d1-d3/a0-a6,-(sp)    *)
         SYSTEM.SETREG(14,IntuitionBase);
         SYSTEM.CODE(04CEFH,00F0FH,0002CH);     (* movem.l 44(sp),d0-d3/a0-a3   *)
         SYSTEM.CODE(0C740H);                   (*  exg     d0,d3               *)
         SYSTEM.CODE(0C541H);                   (*  exg     d1,d2               *)
         SYSTEM.CODE(0C748H);                   (*  exg     a0,a3               *)
         SYSTEM.CODE(0C549H);                   (*  exg     a1,a2               *)
         SYSTEM.CODE(04EAEH,0FEA4H);            (* jsr     -348(a6)             *)
         SYSTEM.CODE(01F40H,0004CH);            (* move.b   d0,76(sp)           *)
         SYSTEM.CODE(04CDFH,07F0EH);            (* movem.l (sp)+,d1-d3/a0-a6    *)
         SYSTEM.CODE(04E75H);                   (* rts                            *)
      END AutoRequest;

      @EntryExitCode

   @END

   (*----------------------------------------------------------------------*)
   (* Put up a requester asking what to do about the problem.              *)
   (*----------------------------------------------------------------------*)

   @NoLongAddressing

   PROCEDURE AskCont(): BOOLEAN;

   TYPE IntuiText = RECORD
           FrontPen : SYSTEM.BYTE;
           BackPen  : SYSTEM.BYTE;
           DrawMode : SYSTEM.BYTE;
           LeftEdge : INTEGER;
           TopEdge  : INTEGER;
           ITextFont: SYSTEM.ADDRESS;
           IText    : SYSTEM.ADDRESS;
           NextText : SYSTEM.ADDRESS;
         END;

   VAR it1,it2,ptext,ntext: IntuiText;
       mess1,cont,abort   : Message;

   BEGIN
     mess1:='Modula-2 Runtime Error';
     cont :=' Cont ';
     abort:=' Abort ';
     WITH it1 DO
       FrontPen  := SYSTEM.BYTE(0);
       DrawMode  := SYSTEM.BYTE(0);
       LeftEdge  := 18;
       TopEdge   := 8;
       ITextFont := SYSTEM.ADDRESS(0);
       IText     := SYSTEM.ADR(mess1);
       NextText  := SYSTEM.ADR(it2);
     END;

     WITH it2 DO
       FrontPen  := SYSTEM.BYTE(0);
       DrawMode  := SYSTEM.BYTE(0);
       LeftEdge  := 18;
       TopEdge   := 18;
       ITextFont := SYSTEM.ADDRESS(0);
       IText     := errorText;
       NextText  := SYSTEM.ADDRESS(0);
     END;

     WITH ntext DO
       FrontPen  := SYSTEM.BYTE(0);
       DrawMode  := SYSTEM.BYTE(0);
       LeftEdge  := 6;
       TopEdge   := 3;
       ITextFont := SYSTEM.ADDRESS(0);
       IText     := SYSTEM.ADR(abort);
       NextText  := SYSTEM.ADDRESS(0);
     END;

     WITH ptext DO
       FrontPen  := SYSTEM.BYTE(0);
       DrawMode  := SYSTEM.BYTE(0);
       LeftEdge  := 6;
       TopEdge   := 3;
       ITextFont := SYSTEM.ADDRESS(0);
       IText     := SYSTEM.ADR(cont);
       NextText  := SYSTEM.ADDRESS(0);
     END;

     RETURN AutoRequest(SYSTEM.ADDRESS(0),SYSTEM.ADR(it1),SYSTEM.ADR(ptext),
                        SYSTEM.ADR(ntext),LONGBITSET(0),LONGBITSET(0),
                        320,72);
   END AskCont;

   (*----------------------------------------------------------------------*)
   (* Set the error message based on the compiler and the errorNo.         *)
   (* If it is a halt, then halt without asking, otherwise ask if user     *)
   (* wants to continue.                                                   *)
   (*----------------------------------------------------------------------*)

   PROCEDURE ProcessError;

   VAR mess: Message;

   BEGIN
      @IF M2S THEN

         CASE errorNo OF
            | -11: errorText:=SYSTEM.ADR('Line 1111 emulation');
            | -10: errorText:=SYSTEM.ADR('Line 1010 emulation');
            | -9 : errorText:=SYSTEM.ADR('Trace exception');
            | -8 : errorText:=SYSTEM.ADR('Privilege violation');
            | -7 : errorText:=SYSTEM.ADR('Arithmetic overflow (TRAPV)');
            | -6 : errorText:=SYSTEM.ADR('Index/range error (CHK)');
            | -5 : errorText:=SYSTEM.ADR('Divide by zero');
            | -4 : errorText:=SYSTEM.ADR('Illegal instruction');
            | -3 : errorText:=SYSTEM.ADR('Address error');
            | -2 : errorText:=SYSTEM.ADR('Bus error');
            |  0 : errorText:=SYSTEM.ADR("Program HALT");
            |  1 : errorText:=SYSTEM.ADR('CASE index out of range');
            |  2 : errorText:=SYSTEM.ADR('No RETURN from function');
            |  3 : errorText:=SYSTEM.ADR('IEEE arithmetic overflow');
            |  4 : errorText:=SYSTEM.ADR('Unimplemented RunTime routine');
         ELSE
            errorText:=SYSTEM.ADR('Unknown error');
         END;

      @ELSIF TDI THEN

         errorNo:=AMIGAX.ErrorContext.Error;
         CASE errorNo OF
            |  3 : mess:='Arithmetic overflow trap';
            |  4 : mess:='Out of range trap';
            |  5 : mess:='Division by zero trap';
            |  7 : mess:='Address error trap';
            |  9 : mess:='Program HALT';
            | 10 : mess:='No RETURN from a function';
            | 11 : mess:='Illegal case index range';
            | 12 : mess:='Stack Overflow';
            | 13 : mess:='Out of range';
            | 14 : mess:='Arithmetic overflow';
            | 15 : mess:='Not enough workspace for new process';
            | 16 : mess:='Process terminated';
            | 17 : mess:='Unimplemented routine';
            | 18 : mess:='Normal return';
         ELSE
            mess:='Unknown error';
         END;
         errorText:=SYSTEM.ADR(mess);

      @ELSE
         errorNo:=HaltNumber;
         mess[0]:=0C;
         errorText:=SYSTEM.ADR(mess);
      @END

      IF (errorNo=HaltNumber) OR NOT AskCont() THEN
         TermProc;
         @IF    M2S THEN
            RunTime.privateInfo2:=NIL;
            task^.tcTrapCode:=PROC(oldTrapCode);
         @ELSIF TDI THEN
            AMIGAX.ErrorProcessor:=PROC(oldTrapCode);
            Libraries.CloseLibrary(IntuitionBase);
         @END
         HALT;
      END;
      @IF TDI THEN
         SYSTEM.SETREG(9,SYSTEM.ADR(AMIGAX.ErrorContext.PC));
         SYSTEM.CODE(02059H);
         SYSTEM.CODE(05489H);           (* restore partial context *)
         SYSTEM.CODE(04CD9H,0E000H);    (* of error and attempt to *)
         SYSTEM.CODE(02859H);           (* resume again            *)
         SYSTEM.CODE(04ED0H);
      @END
   END ProcessError;

   (*-------------------------------------------------------------------*)

   PROCEDURE Nothing;
   BEGIN END Nothing;

   (*-------------------------------------------------------------------*)
   (* Trap handlers to set up M2Sprint error catcher                    *)
   (*-------------------------------------------------------------------*)

   @IF M2S THEN

      @LongAddressing

      PROCEDURE HaltHandler;
      BEGIN
        errorNo:=SYSTEM.REGISTER(0);
        ProcessError;
      END HaltHandler;


      PROCEDURE PostTrap2;
      BEGIN
        SYSTEM.CODE(02F40H,00004H);           (* move.l pc,4(a7) *)
        ProcessError;
      END PostTrap2;

      @NoEntryExitCode

      PROCEDURE PostTrap1;  (* Just used to put a long word on the stack *)
      BEGIN
        PostTrap2;
        SYSTEM.CODE(04E75H);
      END PostTrap1;

      @NoEntryExitCode

      PROCEDURE TrapHandler;
      BEGIN
        SYSTEM.CODE(201FH);           (* move.l (a7)+,d0   trap number *)
        errorNo:=INTEGER(SYSTEM.REGISTER(0));
        errorNo:=-errorNo;
        SYSTEM.CODE(0202FH,00002H);   (* move.l 2(a7),d0   pc *)
        SYSTEM.SETREG(11,PostTrap1);
        SYSTEM.CODE(02F4BH,00002H);   (* move.l a3,2(a7) *)
        SYSTEM.CODE(047163B);         (* RTE *)
      END TrapHandler;

      @EntryExitCode

   @END

   (*********************************************************************)

   @NoLongAddressing

   BEGIN
     TermProc:=Nothing;
     @IF TDI THEN
        IntuitionBase:=Libraries.OpenLibrary("intuition.library",0);
     @END
     @IF    M2S THEN
        RunTime.privateInfo2:=SYSTEM.ADR(HaltHandler);
        task:=RunTime.CurrentProcess;
        oldTrapCode:=PROC(task^.tcTrapCode);
        task^.tcTrapCode:=TrapHandler;
     @ELSIF TDI THEN
        oldTrapCode:=PROC(AMIGAX.ErrorProcessor);
        AMIGAX.ErrorProcessor:=ProcessError;
     @END

@ELSE
  BEGIN
@END

END DBug.