{$S- No stack checking in resident code!                                }
{-----------------------------------------------------------------------}
{ pasres this unit packages the assembler part PASRES.ASM and a number  }
{        of utilities for making pascal programs resident and for       }
{        "calling" them through interrupts.                             }
{-----------------------------------------------------------------------}
{        Original idea and first version for ms-pascal:                 }
{           Christian D'Heureuse, Inventec Informatik, Zurich           }
{        This version implemented in and for Turbo Pascal 5.5           }
{           Hartwig Thomas, (c) Enter AG, Zurich, July 1990             }
{        Update for support of multiple interrupt sources               }
{           Hartwig Thomas and Jens Miehe   Oct 1990                    }
{        Update for INT 08H handling (timer interrupt) and              }
{           documentation by Jens Miehe  Oct/Nov 1990                   }
{        Cleanup and integration of Undocumented DOS by Hartwig Thomas  }
{                                                          April 1991   }
{-----------------------------------------------------------------------}
unit pasres;

interface

type
  prstackptr = ^prstacktype;
  prstacktype = record
    ax, bx, cx, dx, bp, si, di, ds, es, ip, cs, flags : word;
  end;

const
  prtimer    : byte    = $08;
  prhasdos   : boolean = false;

{-----------------------------------------------------------------------}
{ prinit installs the timer and the busy interrupts to handle           }
{        wakeup requests. These interrupts do not need to be            }
{        installed any more but can be activated by a call              }
{        to prwake with counter > 0.                                    }
{        in addition a number of disk safety watchers are installed.    }
{        this procedure must be called prior to any other prinst,       }
{        prwake or prexit call.                                         }
{-----------------------------------------------------------------------}
procedure prinit(prod_code: byte);

{-----------------------------------------------------------------------}
{ prinst installs a software interrupt vector pointing to PRENTRY       }
{        in this unit. The parameters are copied to the 16-byte         }
{        control block in front of the interrupt for identification     }
{        purposes.                                                      }
{        PROD_CODE is used to identify the resident program.            }
{-----------------------------------------------------------------------}
procedure prinst(int_nr: byte; prod_code: byte);

{-----------------------------------------------------------------------}
{ prclear restores an interrupt vector if it has been detected as       }
{         installed by prcheck. (even if called by foreground)          }
{-----------------------------------------------------------------------}
procedure prclear(int_nr: byte);

{-----------------------------------------------------------------------}
{ prcheck is used to check if a version of PASRES is already installed  }
{         resident with a given interrupt vector. If no other           }
{         program has taken over this vector then it returns true       }
{         if such a version is present.                                 }
{         In this case PSP_ADDR, PROD_CODE and PREV_VECT return         }
{         information about the resident program.                       }
{-----------------------------------------------------------------------}
function prcheck(int_nr: byte; var prod_code: byte;
                    var psp_addr: word; var prev_vect: pointer) : boolean;

{-----------------------------------------------------------------------}
{ practive returns the activated interrupt that led to the reawakening  }
{          of the resident program after PREXIT.                        }
{-----------------------------------------------------------------------}
function practive: byte;

{-----------------------------------------------------------------------}
{ prexit passes control from the resident module back to MS-DOS or to   }
{        an application program. The first time it is called, the       }
{        program is made memory resident and control is passed back to  }
{        MS-DOS. When an application program issues the software        }
{        interrupt to activate the resident program, PREXIT gets control}
{        and returns to the resident pascal program. The next time      }
{        PREXIT is called from the resident pascal program, it returns  }
{        to the application program that issued the software interrupt. }
{        The parameter APPL_STACK returns the address of the stack of   }
{        the calling application program. The application stack contains}
{        the values of the machine registers at the time the software   }
{        interrupt was executed. It may be accessed using the           }
{        PRSTACKTYPE structure definition.                              }
{        Before the first call to PREXIT some interrupt must have been  }
{        installed pointing to PRENTRY using PRINST.                    }
{        It is advisable to use SwapVectors immediately before and      }
{        after PREXIT as well as before PRQUIT.                         }
{-----------------------------------------------------------------------}
procedure prexit (var appl_stack: prstackptr);

{-----------------------------------------------------------------------}
{ prcall calls the interrupt vector with the register contents          }
{        indicated. Those are changed by PRCALL (except for CS, IP).    }
{        PRCALL is particularly suited to hand down the interrupt to    }
{        prev_vect.                                                     }
{-----------------------------------------------------------------------}
procedure prcall(intvector: pointer;var call_regs: prstacktype);

{-----------------------------------------------------------------------}
{ prwake sets the activation frequency in units of 1/18.2 seconds       }
{        (= 1/$10000 hours) for TSRs that use the timer interrupt for   }
{        "multitasking".                                                }
{-----------------------------------------------------------------------}
procedure prwake(count:word);

{-----------------------------------------------------------------------}
{ prdontchain permits to override the default that prexit chains the    }
{             old interrupt. It must be called each time.               }
{-----------------------------------------------------------------------}
procedure prdontchain;

{-----------------------------------------------------------------------}
{ prdosavailable returns true, if the critical section flag of DOS is 0 }
{                check this before you use proccupy.                    }
{                If DOS is not available it sets the wakeup request to  }
{                true.                                                  }
{-----------------------------------------------------------------------}
function prdosavailable: boolean;

{-----------------------------------------------------------------------}
{ proccupy makes the context switch complete and opens total DOS acess  }
{          to the resident program. proccupy ought to be called by      }
{          resident programs in their main PREXIT-loop just after       }
{          PREXIT. It sets the current PSP and the critical interrupts. }
{          Only very primitive programs not using any DOS functions can }
{          forego calling proccupy. For file access it is a must.       }
{-----------------------------------------------------------------------}
procedure proccupy;

{-----------------------------------------------------------------------}
{ prrelease reestablishes control of the calling program over DOS. It   }
{           must always be called before the PREXIT is taken and before }
{           PRQUIT, if PROCCUPY has been used before.                   }
{-----------------------------------------------------------------------}
procedure prrelease;

{-----------------------------------------------------------------------}
{ prterm is the opposite of prinit and deinstalls the timer, the busy   }
{        interrupt those disk watching interrupts.                      }
{        it ought to be called prior to prquit or prflush.              }
{-----------------------------------------------------------------------}
procedure prterm;

{-----------------------------------------------------------------------}
{ prquit is used to release (uninstall) the current (resident) program  }
{        and to pass control back to the calling application program.   }
{        PRCLEAR should be called before this routine is called.        }
{-----------------------------------------------------------------------}
procedure prquit;

{-----------------------------------------------------------------------}
{ prflush releases the memory space of a previously installed resident  }
{         program. Any interrupt vectors or active hardware interrupts  }
{         must be cleared and disabled separately.                      }
{-----------------------------------------------------------------------}
procedure prflush(psp_addr   : word);

{=======================================================================}
implementation

uses dos;

const
  busy_int  = $28;

type
  versiontype = array[1 .. 8] of char;
  errinfo = record { for getexterr and setexterr }
              ax: word;
              bx: word;
              cx: word;
            end;

const
  version : versiontype = ('P','R',' ','3','.','0','0',#0);

type
  byteptr = ^byte;
  wordptr = ^word;
  ptrptr  = ^pointer;
  cblockptr = ^cblocktype;
  cblocktype = record
    vname     : versiontype;
    pspseg    : word;
    prodcode  : byte;
    intnr     : byte;    { which interrupt    = ra - 12 }
    prevvect  : pointer; { replaced interrupt = ra - 11 }
    pushf     : byte;    { $9C                = ra - 7  }
    cli       : byte;    { $FA                = ra - 6  (is superfluous!) }
    call      : byte;    { $9A                = ra - 5  }
    calladdr  : pointer; { @prentry           = ra - 4  }
  end;

{$f+}
{$l pasres.obj }
procedure prwakereq;                  external; { byteptr }
procedure prunsafe;                   external; { wordptr }
procedure pr08entry;                  external;
procedure pr13entry;                  external;
procedure pr10entry;                  external;
procedure pr25entry;                  external;
procedure pr26entry;                  external;
procedure pr28entry;                  external;
procedure proldint08;                 external;
procedure proldint13;                 external;
procedure proldint10;                 external;
procedure proldint25;                 external;
procedure proldint26;                 external;
procedure proldint28;                 external;

procedure prexit;                     external;
procedure prcall;                     external;
procedure prterma(psp_addr:word);     external;
procedure prquit;                     external;
procedure prentry;                    external;
function  practive;                   external;
procedure prwake(count:word);         external;
procedure prdontchain;                external;
{$f-}

var
  oldint1B,
  oldint23,
  oldint24,
  mydta,
  olddta : pointer;
  dosmajor,
  oldpsp : word;
  myerr,
  olderr : errinfo;
  dosactiveptr,
  critactiveptr: byteptr; { 0 = dos not in critical error }

{-----------------------------------------------------------------------}
{ macros for sti and cli using the inline directives                    }
{-----------------------------------------------------------------------}
procedure cli; inline($FA);
procedure sti; inline($FB);

{-----------------------------------------------------------------------}
{ dummy procedures for int 1b, 23, 24                                   }
{-----------------------------------------------------------------------}
procedure myint1b(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word); interrupt;
begin
end; { myint1b }

{-----------------------------------------------------------------------}
procedure myint23(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word); interrupt;
begin
end; { myint23 }

{-----------------------------------------------------------------------}
procedure myint24(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp: word); interrupt;
begin
  if (dosmajor >= 3) then ax := 3 else ax := 0;
end; { myint24 }

{-----------------------------------------------------------------------}
{ for getpsp and setpsp see undocumented DOS p. 291 ff.                 }
{-----------------------------------------------------------------------}
function getpsp: word;
var
  regs: registers;
begin { getpsp }
  with regs do if dosmajor = 2 then begin
    critactiveptr^ := $FF;
    ah := $51;
    intr($21,regs);
    critactiveptr^ := 0;
  end
  else begin
    ah := $62;
    intr($21,regs);
  end;
  getpsp := regs.bx;
end; { getpsp }

{-----------------------------------------------------------------------}
procedure setpsp(psp: word);
var
  regs: registers;
begin { setpsp }
  with regs do begin
    critactiveptr^ := $FF;
    ah := $50;
    bx := psp;
    intr($21,regs);
    critactiveptr^ := 0;
  end;
end; { setpsp }

{-----------------------------------------------------------------------}
{ for getexterr and setexterr see p.292 ff.                             }
{-----------------------------------------------------------------------}
procedure getexterr(var err: errinfo);
var
  regs: registers;
begin { getexterr }
  if dosmajor >= 3 then with regs do begin
    ah := $59;
    bx := 0;
    intr($21,regs);
    err.ax := regs.ax;
    err.bx := regs.bx;
    err.cx := regs.cx;
  end;
end; { getexterr }

{-----------------------------------------------------------------------}
procedure setexterr(err: errinfo);
var
  regs: registers;
begin { setexterr }
  if dosmajor >= 3 then with regs do begin
    ah := $5D;
    al := $0A;
    bx := 0;
    ds := seg(err);
    dx := ofs(err);
    intr($21,regs);
  end;
end; { setexterr }

{-----------------------------------------------------------------------}
{ getdta and setdta are just as expected                                }
{-----------------------------------------------------------------------}
function getdta: pointer;
var
  regs: registers;
begin { getdta }
  with regs do begin
    ah := $2F;
    intr($21,regs);
    getdta := ptr(es,bx);
  end;
end; { getdta }

{-----------------------------------------------------------------------}
procedure setdta(dta: pointer);
var
  regs: registers;
begin { setdta }
  with regs do begin
    ah := $1A;
    ds := seg(dta^);
    dx := ofs(dta^);
    intr($21,regs);
  end;
end; { setdta }

{-----------------------------------------------------------------------}
procedure prinit(prod_code: byte);
begin { prinit }
  { set up a number of interrupts for monitoring the unsafe flag }
  getintvec($13,ptrptr(@proldint13)^);
  setintvec($13,@pr13entry);
  getintvec($10,ptrptr(@proldint10)^);
  setintvec($10,@pr10entry);
  getintvec($25,ptrptr(@proldint25)^);
  setintvec($25,@pr25entry);
  getintvec($26,ptrptr(@proldint26)^);
  setintvec($26,@pr26entry);
  { install the dummy handlers }
  setintvec($1B,@myint1B);
  setintvec($23,@myint23);
  setintvec($24,@myint24);
  { install timer and busy interrupt }
  prinst(prtimer,prod_code);
  prinst(busy_int,prod_code);
  { and do the initial vector swapping }
  swapvectors;
end; { prinit }

{-----------------------------------------------------------------------}
procedure prinst(int_nr: byte; prod_code: byte);
var
  cblock : ^cblocktype;
begin { prinst }
  new(cblock);
  with cblock^ do begin
    vname := version;
    pspseg := prefixseg;
    prodcode := prod_code;
    intnr := int_nr;
    getintvec(int_nr,prevvect);
    pushf := $9C;
    cli  := $FA;
    call := $9A;
    if int_nr = prtimer then begin { real timer multitasking }
      calladdr  := @pr08entry;
      ptrptr(@proldint08)^ := prevvect;
    end
    else if int_nr = busy_int then begin
      calladdr := @pr28entry;
      ptrptr(@proldint28)^ := prevvect;
    end
    else calladdr := @prentry;
    { set interrupt to call of new block }
    setintvec(int_nr,addr(pushf));
    { make sure swapvectors uses the right one }
    case int_nr of
      $00: saveint00 := addr(pushf);
      $02: saveint02 := addr(pushf);
      $1B: saveint1B := addr(pushf);
      $21: saveint21 := addr(pushf);
      $23: saveint23 := addr(pushf);
      $24: saveint24 := addr(pushf);
      $34: saveint34 := addr(pushf);
      $35: saveint35 := addr(pushf);
      $36: saveint36 := addr(pushf);
      $37: saveint37 := addr(pushf);
      $38: saveint38 := addr(pushf);
      $39: saveint39 := addr(pushf);
      $3A: saveint3A := addr(pushf);
      $3B: saveint3B := addr(pushf);
      $3C: saveint3C := addr(pushf);
      $3D: saveint3D := addr(pushf);
      $3E: saveint3E := addr(pushf);
      $3F: saveint3F := addr(pushf);
      $75: saveint75 := addr(pushf);
      else
    end;
  end;
end; { prinst }

{-----------------------------------------------------------------------}
procedure prclear(int_nr: byte);
var
  cblock   : ^cblocktype;
begin { prclear }
  {------------------------------------------------------------------------}
  { the whole clearing of interrupts is unsafe if our interrupts have been }
  { replaced! but then even check won't return the correct answer.         }
  { the moral is, you cannot deinstall TSRs with replaced vectors. The     }
  { difference between INT 2F-installation and prcheck tells us, whether   }
  { we are installed but replaced. Obviously for deciding, if one should   }
  { install it again, the 2F-interface is more useful. For deciding on     }
  { deinstallation (and clearing of interrupts) prcheck is to be used.     }
  {------------------------------------------------------------------------}
  getintvec(int_nr,pointer(cblock));
  if (seg(cblock^) > 0) and (ofs(cblock^) >= 16) then dec(word(cblock),16);
  with cblock^ do if (int_nr = intnr) and (vname = version)
  then begin
    setintvec(int_nr,prevvect);
    case int_nr of
      $00: saveint00 := prevvect;
      $02: saveint02 := prevvect;
      $1B: saveint1B := prevvect;
      $21: saveint21 := prevvect;
      $23: saveint23 := prevvect;
      $24: saveint24 := prevvect;
      $34: saveint34 := prevvect;
      $35: saveint35 := prevvect;
      $36: saveint36 := prevvect;
      $37: saveint37 := prevvect;
      $38: saveint38 := prevvect;
      $39: saveint39 := prevvect;
      $3A: saveint3A := prevvect;
      $3B: saveint3B := prevvect;
      $3C: saveint3C := prevvect;
      $3D: saveint3D := prevvect;
      $3E: saveint3E := prevvect;
      $3F: saveint3F := prevvect;
      $75: saveint75 := prevvect;
      else
    end;
  end;
end; { prclear }

{-----------------------------------------------------------------------}
function prcheck(
  {i}       int_nr     : byte;          { interrupt nr                  }
  {o} var   prod_code  : byte;          { old product code              }
  {o} var   psp_addr   : word;          { old PSP address               }
  {o} var   prev_vect  : pointer)       { replaced interrupt vector     }
                       : boolean;
var
  p      : ^cblockptr;
  cblock : cblockptr;
begin { prcheck }
  prcheck := false;
  { replaced getintvec so we don't need dos available for pr checkint }
  { getintvec(int_nr,pointer(cblock)); }
  p := ptr(0,4*int_nr);
  cblock := p^;
  if (seg(cblock^) > 0) and (ofs(cblock^) >= sizeof(cblock^)-7) then begin
    dec(word(cblock),sizeof(cblock^)-7);
    with cblock^ do if (vname = version) and (intnr = int_nr) then begin
      prcheck := true;
      psp_addr  := pspseg;
      prod_code := prodcode;
      prev_vect := prevvect;
    end;
  end;
end; { prcheck }

{-----------------------------------------------------------------------}
procedure prterm;
var
  p: ptrptr;
begin { prterm }
  prclear(busy_int);
  prclear(prtimer);
  getintvec($13,pointer(p));
  dec(word(p),4);
  setintvec($13,p^);
  getintvec($10,pointer(p));
  dec(word(p),4);
  setintvec($10,p^);
  getintvec($25,pointer(p));
  dec(word(p),4);
  setintvec($25,p^);
  getintvec($26,pointer(p));
  dec(word(p),4);
  setintvec($26,p^);
end; { prterm }

{----------------------------------------------------------------------}
function prdosavailable: boolean;
var
  available: boolean;
begin { prdosavailable }
  cli;
  if wordptr(@prunsafe)^ > 0
  then available := false
  else if practive = busy_int
  then available := (dosactiveptr^ <= 1) and (critactiveptr^ = 0)
  else available := (dosactiveptr^ = 0) and (critactiveptr^ = 0);
  if not available then byteptr(@prwakereq)^ := 1;
  prdosavailable := available;
end; { prdosavailable }

{----------------------------------------------------------------------}
procedure proccupy;
var
  regs: registers;
begin { proccupy }
  if not prhasdos then begin
     { get ctrl-break, ctrl-c and critical error handler }
     move(mem[$0000:$006C],oldint1B,4);
     move(saveint1B,mem[$0000:$006C],4);
     move(mem[$0000:$008C],oldint23,4);
     move(saveint23,mem[$0000:$008C],4);
     move(mem[$0000:$0090],oldint24,4);
     move(saveint24,mem[$0000:$0090],4);
     { get and set psp as well as dta and extended error info }
     sti;
     swapvectors;
     getexterr(olderr);
     oldpsp := getpsp;
     olddta := getdta;
     setpsp(prefixseg);
     setdta(mydta);
     setexterr(myerr);
     prhasdos := true;
  end;
end;  { proccupy }

{----------------------------------------------------------------------}
procedure prrelease;
var
  regs: registers;
begin { prrelease }
  if prhasdos then begin
     prhasdos := false;
     getexterr(myerr);
     setdta(olddta);
     setpsp(oldpsp);
     setexterr(olderr);
     swapvectors;
     cli;
     move(oldint1B,mem[$0000:$006C],4);
     move(oldint23,mem[$0000:$008C],4);
     move(oldint24,mem[$0000:$0090],4);
     sti;
  end;
end; { prrelease }

{-----------------------------------------------------------------------}
procedure prflush(psp_addr:word);
begin
  swapvectors;
  prterma(psp_addr);
  swapvectors;
end;

{-----------------------------------------------------------------------}
const
  getindosint = $34;
  getcriterrint = $5D06;
var
  cblock: ^cblocktype;
  regs : registers;
begin
  { get dos version once and for all }
  dosmajor := lo(dosversion);
  { set indos pointer and criterr pointer (p. 287) }
  with regs do begin
    ah := getindosint;
    intr($21,regs);
    dosactiveptr := ptr(es,bx);
    critactiveptr := dosactiveptr;
    if dosmajor < 3 then inc(word(critactiveptr))
    else if dosversion = 3 then dec(word(critactiveptr))
    else begin
      ax := getcriterrint;
      intr($21,regs);
      critactiveptr := ptr(ds,si);
    end;
  end;
  { get a "virgin" myerr }
  getexterr(myerr);
  { get the "original" dta }
  mydta := getdta;
end. { pasres }