Topspeed_JPI/TS-V3/SAVE/TSR.LST

Listing:

    1  (*========================================================
    2  == TopSpeed Modula-2 V3.10                              ==
    3  == demo program:                                        ==
    4  ==                                                      ==
    5  ==        TSR Shell                                     ==
    6  ==                                                      ==
    7  == Installs a "safe" Pop Up program                     ==
    8  ==                                                      ==
    9  ========================================================*)
   10  (*# check(stack=>off,index=>off,range=>off,overflow=>off,nil_ptr=>off) *)
   11  (*# debug(vid=>off)*)
   12  
   13  IMPLEMENTATION MODULE TSR ;
   14                     (* === *)
   15  
   16  
   17  IMPORT IO,Window,Lib,Storage,Str,SYSTEM,TSRLow;
   18  
   19  CONST
   20      KBFuseful   = KBFlagSet { RShift, LShift, Ctrl, Alt } ;
*****                    ^ undeclared identifier
   21  TYPE
   22      TSRmodeType = (Sleeping,Wake,Active,Kill,Dead ) ;
   23  VAR
   24  (*# save, data(volatile=>on) *)
   25        ProgDTA             : ADDRESS ;
   26        ProgPSP             : CARDINAL ;
   27        ActivateScan        : SHORTCARD ;
   28        ActivateFlags       : KBFlagSet ;
   29        KBFlags[40H:17H]    : KBFlagSet ;
   30        TSRproc             : PROC ;
   31        DosNest             : POINTER TO SHORTCARD ;
   32        TSRmode             : TSRmodeType ;
   33        MainProcess         : SYSTEM.PROCESS;
   34  
   35  (*# restore *)
   36  
   37  
   38  PROCEDURE SwapToTSR ;
   39  VAR
   40     op,np : SYSTEM.PROCESS ;
   41  BEGIN
   42     TSRmode := Active ;
   43     np := MainProcess ;
   44     SYSTEM.TRANSFER(op,np) ; (* can't use IOTRANSFER due to chaining problems
   45                                 with other TSRs (SideKick 1, for example) *)
   46     TSRmode := Sleeping ;
   47  END SwapToTSR ;
   48  
   49  
   50  (* Interrupt Handlers *)
   51  (* ================== *)
   52  
   53  (* pragmas for interrupt handler *)
   54  (*# save,
   55      call(interrupt => on,
   56           reg_param => (),
   57           same_ds   => off
   58          )
   59  *)
   60  
   61  TYPE
   62        IPROC       = PROCEDURE();
   63  VAR
   64        Irpt[0:0],   (* Interrupt table *)
   65        SaveIrpt   : ARRAY [0..255] OF IPROC ;
   66  
   67  
   68  PROCEDURE NullInt () ; (* Do nothing interrupt *)
   69  BEGIN
   70  END NullInt;
   71  
   72  PROCEDURE Int9 () ; (* Keyboard H/W interrupt *)
   73  VAR
   74    sc : SHORTCARD ;
   75  BEGIN
   76    sc := SYSTEM.In(60H) ;
   77    IF ((sc=ActivateScan)OR(ActivateScan=0))AND
   78       ((KBFlags*KBFuseful)=ActivateFlags) THEN
   79      sc := SYSTEM.In(61H) ;
   80      SYSTEM.Out(61H,SHORTCARD(BITSET(sc)+{7}));
   81      SYSTEM.Out(61H,sc);
   82      SYSTEM.Out(20H,20H);
   83      IF TSRmode=Sleeping THEN
   84        TSRmode := Wake ;
   85      END ;
   86    ELSE
   87      SaveIrpt[09H]() ; (* Chain Int 28 *)
   88    END ;
   89  END Int9 ;
   90  
   91  VAR
   92    Save28stack : ARRAY[0..3FFH] OF BYTE ;
   93  
   94  PROCEDURE Int28 () ; (* DOS "I'm not doing much" interrupt *)
   95  VAR
   96     base : CARDINAL ;
   97  BEGIN
   98     Lib.Move(ADR(base),ADR(Save28stack),SIZE(Save28stack));
   99     SaveIrpt[28H]() ; (* Chain Int 28 *)
  100     IF (Ofs(base)>100H) AND (TSRmode=Wake) THEN
  101       SwapToTSR ;
  102     END ;
  103     Lib.Move(ADR(Save28stack),ADR(base),SIZE(Save28stack));
  104  END Int28 ;
  105  
  106  
  107  PROCEDURE Int1C () ; (* Timer Interrupt *)
  108  VAR
  109     base : CARDINAL ;
  110  BEGIN
  111     SaveIrpt[1CH]() ; (* Chain Int 1C *)
  112     IF (Ofs(base)>100H)AND(DosNest^ = 0)AND(TSRmode=Wake) THEN
  113       SYSTEM.Out(20H,20H) ; (* Send EOI to timer *)
  114       SwapToTSR ;
  115     END ;
  116  END Int1C ;
  117  
  118  PROCEDURE Int24 () : CARDINAL ; (* Critical Error Interrupt *)
  119  BEGIN
  120     RETURN 0 ;
  121  END Int24;
  122  
  123  (*# restore *)
  124  
  125  PROCEDURE SetIrpt ( N : CARDINAL ; P : IPROC ) ;
  126  VAR
  127    fl : CARDINAL ;
  128  BEGIN
  129    fl := SYSTEM.GetFlags() ; SYSTEM.DI ;
  130    SaveIrpt[N] := Irpt[N] ;
  131    Irpt[N] := P ;
  132    SYSTEM.SetFlags(fl) ;
  133  END SetIrpt ;
  134  
  135  PROCEDURE ResetIrpt ( N : CARDINAL ) ;
  136  VAR
  137    fl : CARDINAL ;
  138  BEGIN
  139    fl := SYSTEM.GetFlags() ; SYSTEM.DI ;
  140    Irpt[N] := SaveIrpt[N] ;
  141    SYSTEM.SetFlags(fl) ;
  142  END ResetIrpt ;
  143  
  144  
  145  
  146  PROCEDURE Resident;
  147         (* ======== *)
  148  
  149  VAR I,F       : CARDINAL;
  150      R         : SYSTEM.Registers;
  151      SaveDTA   : ADDRESS ;
  152      SavePSP   : CARDINAL ;
  153      SaveBrk   : SHORTCARD ;
  154  BEGIN
  155  (* Set Critical Error Handler and break handlers *)
  156    SetIrpt(24H,IPROC(Int24)) ;
  157    SetIrpt(1BH,NullInt);
  158    SetIrpt(23H,NullInt);
  159  (* Change DTA *)
  160    R.AH := 2FH ;
  161    Lib.Dos(R) ;
  162    SaveDTA := [R.ES:R.BX] ;
  163    R.AH := 1AH ;
  164    R.DS := Seg(ProgDTA^) ;
  165    R.DX := Ofs(ProgDTA^) ;
  166    Lib.Dos(R) ;
  167  (* Change PSP *)
  168    R.AX := 5100H ;
  169    Lib.Dos(R) ;
  170    SavePSP := R.BX ;
  171    R.BX := ProgPSP ;
  172    R.AX := 5000H ;
  173    Lib.Dos(R) ;
  174  (* Turn off break flag *)
  175    R.AX := 3300H ;
  176    Lib.Dos(R) ;
  177    SaveBrk := R.DL ;
  178    R.DL := 0 ;
  179    R.AX := 3301H ;
  180    Lib.Dos(R) ;
  181    R.AH := 3;
  182    R.BH := 0;
  183    Lib.Intr(R,010H);
  184    Window.Use(Window.FullScreen);
  185    Window.CursorOff;
  186    Window.SnapShot;
  187    TSRproc() ;
  188    R.AH := 0DH ;
  189    Lib.Dos(R) ;
  190    Window.Use(Window.FullScreen);
  191    Window.CursorOn;
  192    R.AH := 2;
  193    R.BH := 0;
  194    Lib.Intr(R,010H);
  195  
  196  (* Restore break flag *)
  197    R.DL := SaveBrk ;
  198    R.AX := 3301H ;
  199    Lib.Dos(R) ;
  200  (* Restore PSP *)
  201    R.BX := SavePSP ;
  202    R.AX := 5000H ;
  203    Lib.Dos(R) ;
  204  (* Restore DTA *)
  205    R.AH := 1AH ;
  206    R.DS := Seg(SaveDTA^) ;
  207    R.DX := Ofs(SaveDTA^) ;
  208    Lib.Dos(R) ;
  209  (* Restore Critical irpt and break handlers *)
  210    ResetIrpt(24H);
  211    ResetIrpt(1BH);
  212    ResetIrpt(23H);
  213  END Resident;
  214  
  215  VAR
  216    HeapSize : CARDINAL ;
  217  PROCEDURE TermProc ;
  218  VAR
  219    R : SYSTEM.Registers ;
  220    psize : CARDINAL;
  221  BEGIN
  222    psize := TSRLow.ShrinkHeap(HeapSize);
  223    R.AX := 03100H; (*Terminate and stay resident*)
  224    R.DX := psize ;
  225    Lib.Intr(R,21H); (* Use Intr, so as not to trigger the
  226                        Dos re-entry run-time check  *)
  227    (* No Return *)
  228  END TermProc ;
  229  
  230  
  231  PROCEDURE SKinstalled () : BOOLEAN ;
  232  TYPE
  233    AP = POINTER TO ADDRESS ;
  234  VAR
  235    id1 : POINTER TO LONGCARD ;
  236    id2 : POINTER TO CARDINAL ;
  237  BEGIN
  238    id1 := Lib.SubAddr([0:8*4 AP]^,4) ;
  239    id2 := Lib.SubAddr([0:25H*4 AP]^,2) ;
  240    RETURN (id1^=049424B53H)OR(id2^=04B53H) ;
  241  END SKinstalled ;
  242  
  243  PROCEDURE InEnv() : BOOLEAN ;
  244  TYPE Str5 = ARRAY[0..4] OF CHAR;
  245       IDP = POINTER TO Str5;
  246       AP = POINTER TO ADDRESS ;
  247  CONST EnvId = 'TSENV';
  248  VAR  id1 : IDP;
  249  BEGIN
  250    id1 := Lib.SubAddr([0:4*4 AP]^,8) ;
  251    RETURN id1^=Str5(EnvId);
  252  END InEnv;
  253  
  254  
  255  
  256  PROCEDURE Install ( P        : PROC ;      (* Procedure to be invoked *)
  257                      KBF      : KBFlagSet;  (* Shift state to invoke *)
  258                      Scan     : SHORTCARD ; (* Invoking scancode (0=All) *)
  259                      heapsize : CARDINAL    (* Minimum heap required *)
  260                    ) ;
  261  VAR
  262    hp,nhp  : Storage.HeapRecPtr ;
  263    R       : SYSTEM.Registers ;
  264    stack   : ARRAY[0..1023] OF BYTE ;
  265    termp   : SYSTEM.PROCESS ;
  266  
  267  BEGIN
  268    IF InEnv() THEN
  269      Lib.FatalError('Failed to install TSR: should be installed outside the TopSpeed Environment');
  270    END ;
  271    IF SKinstalled() THEN
  272      Lib.FatalError('Failed to install TSR: should be installed BEFORE SideKick ');
  273    END ;
  274    ActivateScan := Scan ;
  275    ActivateFlags := KBF ;
  276    TSRproc := P ;
  277  
  278    R.AH := 52 ;
  279    Lib.Dos(R) ;
  280    DosNest := [R.ES:R.BX] ; (* Dos nesting count *)
  281    R.AH := 2FH ;
  282    Lib.Dos(R) ;
  283    ProgDTA := [R.ES:R.BX] ; (* Current DTA *)
  284    R.AX := 5100H ;
  285    Lib.Dos(R) ;
  286    ProgPSP := R.BX ;        (* Current PSP *)
  287  
  288  (* Install Interrupt handlers *)
  289    SetIrpt(09H,Int9);
  290    SetIrpt(1CH,Int1C);
  291    SetIrpt(28H,Int28);
  292    SYSTEM.NEWPROCESS( TermProc, ADR(stack), SIZE(stack) , termp );
  293    HeapSize := heapsize ;
  294    TSRmode := Sleeping ;
  295    REPEAT
  296      SYSTEM.TRANSFER(MainProcess,termp) ;
  297      Resident ;
  298    UNTIL TSRmode = Dead ;
  299  END Install ;
  300  
  301  PROCEDURE DeInstall ;
  302  TYPE
  303    BP = POINTER TO SHORTCARD ;
  304    CP = POINTER TO CARDINAL ;
  305  VAR
  306    s : CARDINAL ;
  307    R : SYSTEM.Registers ;
  308  BEGIN
  309    IF TSRmode<>Dead THEN
  310      TSRmode := Dead ;
  311      ResetIrpt(09H);
  312      ResetIrpt(1CH);
  313      ResetIrpt(28H);
  314      R.AH := 52H ;
  315      Lib.Dos(R);
  316      s := [R.ES:R.BX-2 CP]^;
  317      WHILE [s:0 BP]^ = 4DH DO
  318        IF [s:1 CP]^ = ProgPSP THEN
  319          R.AH := 49H ;
  320          R.ES := s+1 ;
  321          Lib.Dos(R) ;
  322        END ;
  323        INC(s,[s:3 CP]^+1);
  324      END ;
  325    END ;
  326  END DeInstall ;
  327  
  328  VAR
  329    Continue  : PROC ;
  330  
  331  PROCEDURE Closedown ;
  332  BEGIN
  333       DeInstall ;
  334       Continue() ;
  335  END Closedown ;
  336  
  337  
  338  BEGIN
  339    TSRmode := Dead ;
  340    Lib.Terminate(Closedown,Continue) ;
  341  END TSR.
  342  
  343  (*======================================================*)
  344  

    1 error