(*========================================================
== TopSpeed Modula-2 V3.10                              ==
== demo program:                                        ==
==                                                      ==
==        TSR Shell                                     ==
==                                                      ==
== Installs a "safe" Pop Up program                     ==
==                                                      ==
========================================================*)
(*# check(stack=>off,index=>off,range=>off,overflow=>off,nil_ptr=>off) *)
(*# debug(vid=>off)*)

IMPLEMENTATION MODULE TSR ;
                   (* === *)


IMPORT IO,Window,Lib,Storage,Str,SYSTEM,TSRLow;

CONST
    KBFuseful   = KBFlagSet { RShift, LShift, Ctrl, Alt } ;
TYPE
    TSRmodeType = (Sleeping,Wake,Active,Kill,Dead ) ;
VAR
(*# save, data(volatile=>on) *)
      ProgDTA             : ADDRESS ;
      ProgPSP             : CARDINAL ;
      ActivateScan        : SHORTCARD ;
      ActivateFlags       : KBFlagSet ;
      KBFlags[40H:17H]    : KBFlagSet ;
      TSRproc             : PROC ;
      DosNest             : POINTER TO SHORTCARD ;
      TSRmode             : TSRmodeType ;
      MainProcess         : SYSTEM.PROCESS;

(*# restore *)


PROCEDURE SwapToTSR ;
VAR
   op,np : SYSTEM.PROCESS ;
BEGIN
   TSRmode := Active ;
   np := MainProcess ;
   SYSTEM.TRANSFER(op,np) ; (* can't use IOTRANSFER due to chaining problems
                               with other TSRs (SideKick 1, for example) *)
   TSRmode := Sleeping ;
END SwapToTSR ;


(* Interrupt Handlers *)
(* ================== *)

(* pragmas for interrupt handler *)
(*# save,
    call(interrupt => on,
         reg_param => (),
         same_ds   => off
        )
*)

TYPE
      IPROC       = PROCEDURE();
VAR
      Irpt[0:0],   (* Interrupt table *)
      SaveIrpt   : ARRAY [0..255] OF IPROC ;


PROCEDURE NullInt () ; (* Do nothing interrupt *)
BEGIN
END NullInt;

PROCEDURE Int9 () ; (* Keyboard H/W interrupt *)
VAR
  sc : SHORTCARD ;
BEGIN
  sc := SYSTEM.In(60H) ;
  IF ((sc=ActivateScan)OR(ActivateScan=0))AND
     ((KBFlags*KBFuseful)=ActivateFlags) THEN
    sc := SYSTEM.In(61H) ;
    SYSTEM.Out(61H,SHORTCARD(BITSET(sc)+{7}));
    SYSTEM.Out(61H,sc);
    SYSTEM.Out(20H,20H);
    IF TSRmode=Sleeping THEN
      TSRmode := Wake ;
    END ;
  ELSE
    SaveIrpt[09H]() ; (* Chain Int 28 *)
  END ;
END Int9 ;

VAR
  Save28stack : ARRAY[0..3FFH] OF BYTE ;

PROCEDURE Int28 () ; (* DOS "I'm not doing much" interrupt *)
VAR
   base : CARDINAL ;
BEGIN
   Lib.Move(ADR(base),ADR(Save28stack),SIZE(Save28stack));
   SaveIrpt[28H]() ; (* Chain Int 28 *)
   IF (Ofs(base)>100H) AND (TSRmode=Wake) THEN
     SwapToTSR ;
   END ;
   Lib.Move(ADR(Save28stack),ADR(base),SIZE(Save28stack));
END Int28 ;


PROCEDURE Int1C () ; (* Timer Interrupt *)
VAR
   base : CARDINAL ;
BEGIN
   SaveIrpt[1CH]() ; (* Chain Int 1C *)
   IF (Ofs(base)>100H)AND(DosNest^ = 0)AND(TSRmode=Wake) THEN
     SYSTEM.Out(20H,20H) ; (* Send EOI to timer *)
     SwapToTSR ;
   END ;
END Int1C ;

PROCEDURE Int24 () : CARDINAL ; (* Critical Error Interrupt *)
BEGIN
   RETURN 0 ;
END Int24;

(*# restore *)

PROCEDURE SetIrpt ( N : CARDINAL ; P : IPROC ) ;
VAR
  fl : CARDINAL ;
BEGIN
  fl := SYSTEM.GetFlags() ; SYSTEM.DI ;
  SaveIrpt[N] := Irpt[N] ;
  Irpt[N] := P ;
  SYSTEM.SetFlags(fl) ;
END SetIrpt ;

PROCEDURE ResetIrpt ( N : CARDINAL ) ;
VAR
  fl : CARDINAL ;
BEGIN
  fl := SYSTEM.GetFlags() ; SYSTEM.DI ;
  Irpt[N] := SaveIrpt[N] ;
  SYSTEM.SetFlags(fl) ;
END ResetIrpt ;



PROCEDURE Resident;
       (* ======== *)

VAR I,F       : CARDINAL;
    R         : SYSTEM.Registers;
    SaveDTA   : ADDRESS ;
    SavePSP   : CARDINAL ;
    SaveBrk   : SHORTCARD ;
BEGIN
(* Set Critical Error Handler and break handlers *)
  SetIrpt(24H,IPROC(Int24)) ;
  SetIrpt(1BH,NullInt);
  SetIrpt(23H,NullInt);
(* Change DTA *)
  R.AH := 2FH ;
  Lib.Dos(R) ;
  SaveDTA := [R.ES:R.BX] ;
  R.AH := 1AH ;
  R.DS := Seg(ProgDTA^) ;
  R.DX := Ofs(ProgDTA^) ;
  Lib.Dos(R) ;
(* Change PSP *)
  R.AX := 5100H ;
  Lib.Dos(R) ;
  SavePSP := R.BX ;
  R.BX := ProgPSP ;
  R.AX := 5000H ;
  Lib.Dos(R) ;
(* Turn off break flag *)
  R.AX := 3300H ;
  Lib.Dos(R) ;
  SaveBrk := R.DL ;
  R.DL := 0 ;
  R.AX := 3301H ;
  Lib.Dos(R) ;
  R.AH := 3;
  R.BH := 0;
  Lib.Intr(R,010H);
  Window.Use(Window.FullScreen);
  Window.CursorOff;
  Window.SnapShot;
  TSRproc() ;
  R.AH := 0DH ;
  Lib.Dos(R) ;
  Window.Use(Window.FullScreen);
  Window.CursorOn;
  R.AH := 2;
  R.BH := 0;
  Lib.Intr(R,010H);

(* Restore break flag *)
  R.DL := SaveBrk ;
  R.AX := 3301H ;
  Lib.Dos(R) ;
(* Restore PSP *)
  R.BX := SavePSP ;
  R.AX := 5000H ;
  Lib.Dos(R) ;
(* Restore DTA *)
  R.AH := 1AH ;
  R.DS := Seg(SaveDTA^) ;
  R.DX := Ofs(SaveDTA^) ;
  Lib.Dos(R) ;
(* Restore Critical irpt and break handlers *)
  ResetIrpt(24H);
  ResetIrpt(1BH);
  ResetIrpt(23H);
END Resident;

VAR
  HeapSize : CARDINAL ;
PROCEDURE TermProc ;
VAR
  R : SYSTEM.Registers ;
  psize : CARDINAL;
BEGIN
  psize := TSRLow.ShrinkHeap(HeapSize);
  R.AX := 03100H; (*Terminate and stay resident*)
  R.DX := psize ;
  Lib.Intr(R,21H); (* Use Intr, so as not to trigger the
                      Dos re-entry run-time check  *)
  (* No Return *)
END TermProc ;


PROCEDURE SKinstalled () : BOOLEAN ;
TYPE
  AP = POINTER TO ADDRESS ;
VAR
  id1 : POINTER TO LONGCARD ;
  id2 : POINTER TO CARDINAL ;
BEGIN
  id1 := Lib.SubAddr([0:8*4 AP]^,4) ;
  id2 := Lib.SubAddr([0:25H*4 AP]^,2) ;
  RETURN (id1^=049424B53H)OR(id2^=04B53H) ;
END SKinstalled ;

PROCEDURE InEnv() : BOOLEAN ;
TYPE Str5 = ARRAY[0..4] OF CHAR;
     IDP = POINTER TO Str5;
     AP = POINTER TO ADDRESS ;
CONST EnvId = 'TSENV';
VAR  id1 : IDP;
BEGIN
  id1 := Lib.SubAddr([0:4*4 AP]^,8) ;
  RETURN id1^=Str5(EnvId);
END InEnv;



PROCEDURE Install ( P        : PROC ;      (* Procedure to be invoked *)
                    KBF      : KBFlagSet;  (* Shift state to invoke *)
                    Scan     : SHORTCARD ; (* Invoking scancode (0=All) *)
                    heapsize : CARDINAL    (* Minimum heap required *)
                  ) ;
VAR
  hp,nhp  : Storage.HeapRecPtr ;
  R       : SYSTEM.Registers ;
  stack   : ARRAY[0..1023] OF BYTE ;
  termp   : SYSTEM.PROCESS ;

BEGIN
  IF InEnv() THEN
    Lib.FatalError('Failed to install TSR: should be installed outside the TopSpeed Environment');
  END ;
  IF SKinstalled() THEN
    Lib.FatalError('Failed to install TSR: should be installed BEFORE SideKick ');
  END ;
  ActivateScan := Scan ;
  ActivateFlags := KBF ;
  TSRproc := P ;

  R.AH := 52 ;
  Lib.Dos(R) ;
  DosNest := [R.ES:R.BX] ; (* Dos nesting count *)
  R.AH := 2FH ;
  Lib.Dos(R) ;
  ProgDTA := [R.ES:R.BX] ; (* Current DTA *)
  R.AX := 5100H ;
  Lib.Dos(R) ;
  ProgPSP := R.BX ;        (* Current PSP *)

(* Install Interrupt handlers *)
  SetIrpt(09H,Int9);
  SetIrpt(1CH,Int1C);
  SetIrpt(28H,Int28);
  SYSTEM.NEWPROCESS( TermProc, ADR(stack), SIZE(stack) , termp );
  HeapSize := heapsize ;
  TSRmode := Sleeping ;
  REPEAT
    SYSTEM.TRANSFER(MainProcess,termp) ;
    Resident ;
  UNTIL TSRmode = Dead ;
END Install ;

PROCEDURE DeInstall ;
TYPE
  BP = POINTER TO SHORTCARD ;
  CP = POINTER TO CARDINAL ;
VAR
  s : CARDINAL ;
  R : SYSTEM.Registers ;
BEGIN
  IF TSRmode<>Dead THEN
    TSRmode := Dead ;
    ResetIrpt(09H);
    ResetIrpt(1CH);
    ResetIrpt(28H);
    R.AH := 52H ;
    Lib.Dos(R);
    s := [R.ES:R.BX-2 CP]^;
    WHILE [s:0 BP]^ = 4DH DO
      IF [s:1 CP]^ = ProgPSP THEN
        R.AH := 49H ;
        R.ES := s+1 ;
        Lib.Dos(R) ;
      END ;
      INC(s,[s:3 CP]^+1);
    END ;
  END ;
END DeInstall ;

VAR
  Continue  : PROC ;

PROCEDURE Closedown ;
BEGIN
     DeInstall ;
     Continue() ;
END Closedown ;


BEGIN
  TSRmode := Dead ;
  Lib.Terminate(Closedown,Continue) ;
END TSR.

(*======================================================*)