home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / STAY50.ZIP / SR50SUBS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-28  |  19.6 KB  |  474 lines
  1.  
  2. {$I direct.inc}
  3. {────────────────────────────────────────────────────────────────────────────}
  4. {  SR50Subs.Pas                                                              }
  5. {                                                                            }
  6. {  Copyright (c) 1988 Lane H. Ferris                                         }
  7. {────────────────────────────────────────────────────────────────────────────}
  8.  
  9.   unit SR50Subs  ;
  10.   {────────────────────────────────────────────────────────────────────────}
  11.                                interface
  12.   {────────────────────────────────────────────────────────────────────────}
  13.  
  14.   uses dos,crt ;
  15.  
  16.   const
  17.  
  18.    Haltlevel =  1 ;                    { Error msg action levels }
  19.    Warnlevel =  2 ;
  20.    Infolevel =  4 ;
  21.  
  22.   type
  23.    lcstringtype = string[255] ;
  24.    string4      = string[4]   ;
  25.    string9      = string[9]   ;
  26.  
  27.   var
  28.    DosVersion        : byte     ;      { Current Version of DOS        }
  29.    DosCriticalStatus : pointer  ;      { Dos Critical Status byte ptr  }
  30.    InDosStatus       : pointer  ;      { Dos Active status byte ptr    }
  31.    InDosStackptr     : pointer  ;      { ofs within Dos of InDos stack }
  32.  
  33.    Procedure Caps       (var lcstring : string)     ;
  34.    Procedure ErrorMsg   ( SeverityLevel : integer ; Message : string) ;
  35.    Procedure GetDTA     ( var DTAvector : pointer ) ;
  36.    Procedure GetPSP     ( var segment : word )      ;
  37.    Function  Hexword    ( hexint:word) :string4     ;
  38.    Function  HexPtr     ( hexinptr :pointer) :string9       ;
  39.    Procedure BorderWindow (xlo,ylo,xhi,yhi : byte; border : boolean)    ;
  40.    Function  PtrDiff    (Ptr1, Ptr2 : pointer ) : longint ;
  41.    Procedure RestoreWindow(xlo,ylo,xhi,yhi :integer ;pwindowptr :pointer) ;
  42.    Procedure SaveWindow(xlo,ylo,xhi,yhi :integer ;var windowptr :pointer) ;
  43.    Procedure SetDTA     ( DTAvector : pointer )     ;
  44.    Procedure SetPSP     ( var segment : word  )     ;
  45.    Function  UpperCase(var lcstring :lcstringtype) :lcstringtype;
  46.   {────────────────────────────────────────────────────────────────────────}
  47.                              implementation
  48.   {────────────────────────────────────────────────────────────────────────}
  49.   uses macros ,
  50.        SR50 ;
  51.  
  52.  
  53. TYPE
  54.     String2  = string[2]  ;
  55.     string80 = string[80] ;
  56.  
  57.  
  58. CONST
  59.     carry           = 1  ;               {carry flag in Flag register}
  60.  
  61.                                       {('╒', '═', '╕', '└', '─', '┘', '│')}
  62.     borderchars: array[1..7] of word = (213, 205, 184, 192, 196, 217, 179);
  63.  
  64.  var
  65.   videobuf : word ;
  66.  
  67. {──────────────────────────────────────────────────────────────────}
  68. {                            Caps                                  }
  69. {──────────────────────────────────────────────────────────────────}
  70. {                convert string to upper case                      }
  71. {──────────────────────────────────────────────────────────────────}
  72.  Procedure Caps(var lcstring:string) ;
  73.   var
  74.    i :integer ;
  75.   begin
  76.   for i := 1 to length(lcstring) do
  77.      lcstring[i] := upcase(lcstring[i]) ;
  78.  End { Caps } ;
  79. {──────────────────────────────────────────────────────────────────}
  80. {                          PtrDiff                                 }
  81. {──────────────────────────────────────────────────────────────────}
  82. {                  Returns byte difference in pointers             }
  83. {──────────────────────────────────────────────────────────────────}
  84.     FUNCTION PtrDiff(Ptr1, Ptr2 : pointer ) : longint ;
  85.     var
  86.      tmpwrd : longint ;
  87.     BEGIN
  88.       tmpwrd := ( vec(ptr1).seg - vec(ptr2).seg ) shl 4  ;
  89.       tmpwrd := tmpwrd + ( vec(ptr1).ofs - vec(ptr2).ofs )  ;
  90.       PtrDiff := tmpwrd ;
  91.     END;
  92.       {─────────────────────────────────────────────────────────}
  93.       {                    SET DTA                              }
  94.       {─────────────────────────────────────────────────────────}
  95.    Procedure SetDTA(DTAvector : pointer );
  96.    var
  97.     regs : registers ;
  98.    BEGIN
  99.      regs.ax := $1A00                ;   { get current DTA function       }
  100.      regs.Ds := vec(DTAvector).seg   ;   { Segment of DTA returned by DOS }
  101.      regs.Dx := vec(DTAvector).ofs   ;   { Offset of DTA returned         }
  102.      intr($21,regs)                  ;
  103.    END;
  104.       {─────────────────────────────────────────────────────────}
  105.       {                 G E  T    D  T  A                       }
  106.       {─────────────────────────────────────────────────────────}
  107.    Procedure GetDTA(var DTAvector : pointer );
  108.    VAR  regs : registers;
  109.    BEGIN
  110.      regs.ax := $2F00 ;                { get current DTA address }
  111.      intr($21, regs ) ;                { Execute MSDos function  }
  112.      vec(DTAvector).seg := regs.ES;    { DTA segment from DOS    }
  113.      vec(DTAvector).ofs := regs.Bx;    { DTA Offset returned     }
  114.    END;
  115.  
  116.       {─────────────────────────────────────────────────────────}
  117.       {                 S E  T    P  S  P                       }
  118.       {─────────────────────────────────────────────────────────}
  119.    Procedure SetPSP(var segment : word );
  120.    var
  121.     regs : registers ;
  122.    BEGIN
  123.  
  124.      { A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack   }
  125.      { when the PSP get/set functions are issued at the DOS prompt. The  }
  126.      { following checks are made, forcing DOS to use the "critical"      }
  127.      { stack when the TSR enters at the INDOS level.                     }
  128.  
  129.                                     {If Version less then 3.0 and INDOS set }
  130.      If DosVersion < 3 then         { then set the Dos Critical Flag        }
  131.      IF ( byte(DosCriticalStatus^) or
  132.           byte(InDosStatus^) ) = 0 then {ok}
  133.         else  byte(DosCriticalStatus^) := $FF ;
  134.  
  135.      regs.ax := $5000   ;      { Function to set new PSP address }
  136.      regs.bx := segment ;      { Segment of PSP returned by DOS  }
  137.      Intr($21, regs)    ;      { Execute MSDos function request  }
  138.  
  139.                                { If Version less then 3.0 and INDOS on }
  140.      If DosVersion < 3 then    { then clear the Dos Critical Flag      }
  141.      IF ( byte(DosCriticalStatus^) or
  142.           byte(InDosStatus^) ) = 0 then {}
  143.          else  byte(DosCriticalStatus^) := $00 ;
  144.  
  145.    END;
  146.       {─────────────────────────────────────────────────────────}
  147.       {                 G E  T    P  S  P                       }
  148.       {─────────────────────────────────────────────────────────}
  149.    Procedure GetPSP(var segment : word );
  150.    var
  151.     regs : registers ;
  152.    BEGIN
  153.  
  154.      { A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack   }
  155.      { when the PSP get/set functions are issued at the DOS prompt. The  }
  156.      { following checks are made, forcing DOS to use the "critical"      }
  157.      { stack when the TSR enters at the INDOS level.                     }
  158.  
  159.                                {If Version less then 3.0 and INDOS set }
  160.      If DosVersion < 3 then         { then set the Dos Critical Flag        }
  161.      IF ( byte(DosCriticalStatus^) or
  162.           byte(InDosStatus^) ) = 0 then {ok}
  163.         else  byte(DosCriticalStatus^) := $FF ;
  164.  
  165.      regs.ax := $5100   ;    { Function to get current PSP address }
  166.      intr($21,regs )    ;    { Execute MSDos function request }
  167.      segment := regs.Bx ;    { Segment of PSP returned by DOS }
  168.  
  169.                                {IF DOS Version less then 3.0 and INDOS set }
  170.      If DosVersion < 3 then    { then clear the Dos Critical Flag      }
  171.      IF ( byte(DosCriticalStatus^) or
  172.           byte(InDosStatus^) ) = 0 then {}
  173.          else  byte(DosCriticalStatus^) := $00 ;
  174.  
  175.    END;
  176.     {───────────────────────────────────────────────────────────────}
  177.     {        G e t   C o n t r o l  C (break)  V e c t o r          }
  178.     {───────────────────────────────────────────────────────────────}
  179. Type
  180.     Arrayparam = array [1..2] of integer;
  181. Const
  182.      SavedCtlC: arrayparam = (0,0);
  183.      NewCtlC  : arrayparam = (0,0);
  184.  Procedure GetCtlC(Var SavedCtlC:arrayparam);
  185.    var
  186.     regs : registers ;
  187.     Begin                     {Record the Current Ctrl-C Vector}
  188.        With Regs Do
  189.        Begin
  190.        AX := $3523        ;
  191.        intr($21,Regs)     ;
  192.        SavedCtlC[1] := BX ;
  193.        SavedCtlC[2] := ES ;
  194.        End                ;
  195.     End;
  196.     {───────────────────────────────────────────────────────────────}
  197.     {        S e t   C o n t r o l  C   V e c t o r                 }
  198.     {───────────────────────────────────────────────────────────────}
  199.  Procedure SetCtlC(Var CtlCptr:arrayparam);
  200.   var
  201.    regs : registers ;
  202.  
  203.     Begin                     {Set the New Ctrl-C Vector}
  204.        With Regs Do
  205.        Begin
  206.         AX := $2523      ;
  207.         DS := CtlCptr[2] ;
  208.         DX := CtlCptr[1] ;
  209.         intr($21,Regs)   ;
  210.        End               ;
  211.     End ;
  212.       {─────────────────────────────────────────────────────────}
  213.       {        U p p e r  C a s e   of  string                  }
  214.       {─────────────────────────────────────────────────────────}
  215. Function UpperCase(var lcstring :lcstringtype) :lcstringtype;
  216.    VAR
  217.      i :integer;
  218.     Begin
  219.         for i := 1 to ord(lcstring[0]) do
  220.           lcstring[i] := upcase(lcstring[i]);
  221.         UpperCase := lcstring;
  222.     end{uppercase};
  223.       {─────────────────────────────────────────────────────────}
  224.       {        HexByte        B y t e  t o   A s c i i          }
  225.       {─────────────────────────────────────────────────────────}
  226.   Function Hexbyte(hexint:byte) :string2;
  227.     CONST
  228.       Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
  229.                                        'A','B','C','D','E','F');
  230.     VAR
  231.       i :integer;
  232.       tempstring :string2;
  233.     BEGIN {Hexbyte}
  234.       tempstring[0] := #2;  {force string length of two}
  235.       For i := 1 to 2 do
  236.         tempstring[i] := Hexchars[ hexint shr (4*(2-i)) and $0F ];
  237.         Hexbyte := tempstring;
  238.     END   {Hexbyte};
  239.     {─────────────────────────────────────────────────────────}
  240.     {          HexWord          H e x   t o   A s c i i       }
  241.     {─────────────────────────────────────────────────────────}
  242.   Function Hexword(hexint:word) :string4;
  243.     CONST
  244.       Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
  245.                                        'A','B','C','D','E','F');
  246.     VAR
  247.       i :integer;
  248.       tempstring :string4;
  249.     BEGIN {Hexword}
  250.       tempstring[0] := #4;  {force string length of four}
  251.       For i := 1 to 4 do
  252.         tempstring[i] := Hexchars[ hexint shr (4*(4-i)) and $000F ];
  253.         Hexword := tempstring;
  254.     END   {Hexword};
  255.  
  256.   {───────────────────────────────────────────────────────────}
  257.   {               HexPtr                                      }
  258.   {───────────────────────────────────────────────────────────}
  259.   Function HexPtr(hexinptr :pointer) :string9;
  260.     CONST
  261.       Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
  262.                                        'A','B','C','D','E','F');
  263.     var
  264.       ptrin : vector absolute hexinptr ;
  265.  
  266.       i :integer;
  267.       tempstring :string9;
  268.     BEGIN {HexPtr}
  269.       tempstring[0] := #9;  {force string length of nine}
  270.       For i := 1 to 4 do
  271.         tempstring[i] := Hexchars[ ptrin.seg shr (4*(4-i)) and $000F ];
  272.       tempstring[5] := '.'      ;
  273.       For i := 6 to 9 do
  274.         tempstring[i] := Hexchars[ ptrin.ofs shr (4*(9-i)) and $000F ];
  275.       HexPtr := tempstring ;
  276.     END   {HexPtr};
  277. {──────────────────────────────────────────────────────────────────}
  278. {                    Error Msg                                     }
  279. {──────────────────────────────────────────────────────────────────}
  280.   Procedure ErrorMsg ( SeverityLevel : integer ;
  281.                        Message       : string  ) ;
  282.   var
  283.    oldx,oldy : byte    ;
  284.   Begin
  285.  
  286.    resource(reserve,_CRT) ;
  287.    Oldx := wherex      ;                { save cursor position }
  288.    Oldy := wherey      ;
  289.    Gotoxy(1,1)         ;                { message on top line  }
  290.    writeln ( Message ) ;                { write message to crt }
  291.  
  292.    if SeverityLevel = HaltLevel then begin
  293.       write(^G,'Sever Error, Halting Program') ;
  294.       Halt(SeverityLevel)                      ;
  295.       end                                      ;
  296.  
  297.    Gotoxy(Oldx,Oldy)      ;                { return cursor     }
  298.    resource(rlse,_CRT)    ;
  299.  
  300.   End {ErrorMsg} ;
  301.   {───────────────────────────────────────────────────────────}
  302.   {                      SaveWindow                           }
  303.   {───────────────────────────────────────────────────────────}
  304.    Procedure  SaveWindow(xlo,ylo,xhi,yhi :integer ;
  305.                               var windowptr :pointer) ;
  306.     var
  307.      xlth,ylth       : integer ;
  308.      windowsize      : integer ;
  309.      videoofs        : word    ;
  310.      i               : integer ;
  311.  
  312.     BEGIN
  313.       xlth := xhi-xlo+1 ;                    { from old SRB window     }
  314.       ylth := yhi-ylo+1 ;
  315.       windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2  ;
  316.       getmem(windowptr,windowsize)               ;
  317.       Videoofs   := ((ylo-1)*80 + (xlo-1))*2     ;
  318.       push(vec(windowptr).ofs) ;               { save window }
  319.       for i := 0 to ylth-1 do begin
  320.        move( ptr(Videoseg,Videoofs+i*160)^, windowptr^, xlth*2) ;
  321.        incptr(windowptr,xlth*2)                                 ;
  322.        end                                                      ;
  323.       pop(vec(windowptr).ofs) ;
  324.  
  325.     End { SaveWindow }        ;
  326.   {───────────────────────────────────────────────────────────}
  327.   {                      RestoreWindow                        }
  328.   {───────────────────────────────────────────────────────────}
  329.    Procedure  RestoreWindow(xlo,ylo,xhi,yhi :integer ;
  330.                                    pwindowptr :pointer) ;
  331.     var
  332.      xlth,ylth       : integer ;
  333.      windowptr       : pointer ;
  334.      windowsize      : integer ;
  335.      videoofs        : word    ;
  336.      i               : integer ;
  337.     Begin
  338.       windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2  ;
  339.       windowptr := pwindowptr ;
  340.       xlth := xhi-xlo+1 ;
  341.       ylth := yhi-ylo+1 ;
  342.       Videoofs   := ((ylo-1)*80 + (xlo-1))*2     ;
  343.       push(vec(windowptr).ofs)                   ;
  344.       for i := 0 to ylth-1 do begin
  345.        move(windowptr^,ptr(Videoseg,Videoofs+i*160)^,xlth*2) ;
  346.        incptr(windowptr,xlth*2)                              ;
  347.        end                                                   ;
  348.       pop(vec(windowptr).ofs) ;
  349.       freemem(windowptr,windowsize) ;
  350.     End {Restore Window} ;
  351.  
  352.   {───────────────────────────────────────────────────────────}
  353.   {                      BorderWindow                         }
  354.   {───────────────────────────────────────────────────────────}
  355.    Procedure BorderWindow (xlo,ylo,xhi,yhi : byte; border : boolean)    ;
  356.     var
  357.      i          : integer ;
  358.      xlth,ylth  : integer ;
  359.      windowsize : integer ;
  360.      videoofs   : word    ;
  361.  
  362.     BEGIN {BorderWindow}
  363.  
  364.      xlth := xhi-xlo+1 ;
  365.      ylth := yhi-ylo+1 ;
  366.      windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2  ;
  367.      Videoofs   := ((ylo-1)*80 + (xlo-1))*2     ;
  368.  
  369.  
  370.     crt.Window(xlo,ylo,xhi,yhi) ;   { make a new  window }
  371.  
  372.     if Border then begin
  373.       for i := 0 to xlth-1 do               { top border }
  374.        move( borderchars[2], ptr(videobuf,Videoofs+i*2)^,    2) ;
  375.       move( borderchars[1], ptr(videobuf,Videoofs)^,        2) ;
  376.       move( borderchars[3], ptr(videobuf,Videoofs+(xlth-1)*2)^, 2) ;
  377.  
  378.       push(Videoofs) ;
  379.       Videoofs := Videoofs+(ylth-1)*160 ;
  380.       for i := 0 to xlth-1 do               { bottom border }
  381.        move( borderchars[5], ptr(videobuf,Videoofs+i*2)^,        2) ;
  382.       move( borderchars[4], ptr(videobuf,Videoofs)^,            2) ;
  383.       move( borderchars[6], ptr(videobuf,Videoofs+(xlth-1)*2)^, 2) ;
  384.       pop(Videoofs) ;
  385.  
  386.       push(Videoofs) ;
  387.       Videoofs := Videoofs+160 ;               { side borders }
  388.       for i := 1 to ylth-2 do begin
  389.        move( borderchars[7], ptr(videobuf,Videoofs)^,       2) ;
  390.        move( borderchars[7], ptr(videobuf,Videoofs+(xlth-1)*2)^,2) ;
  391.        inc(Videoofs,160) ;
  392.        end ;
  393.       pop(Videoofs)     ;
  394.     crt.window(xlo+1,ylo+1,xhi-1,yhi-1) ; { move inside border }
  395.    end {if border }    ;
  396.  
  397.     clrscr ;
  398.  
  399.     END   {BorderWindow};
  400.   {─────────────────────────────────────────────────────────────────}
  401.   {                     initialization                              }
  402.   {─────────────────────────────────────────────────────────────────}
  403.   var
  404.    regs            : registers ;
  405.    byteptr         : pointer   ;
  406.    FoundInDosStack : boolean   ;
  407.    i               : integer   ;
  408.  
  409.   begin { unit initialization }
  410.  
  411.     {DosVersion must be initialized before PSP and DTA calls }
  412.  
  413.   With regs do BEGIN
  414.     Ax := $3000      ;                   { Obtain the DOS Version number }
  415.     Intr($21,Regs)   ;
  416.     DosVersion := Al ;                   { 0=1+, 2=2.0+, 3=3.0+ }
  417.     Ah := $34        ;                   { get Dos Critical flag ptr }
  418.     Intr($21, regs ) ;                   { and InDos status flag ptr }
  419.     InDosStatus       := ptr( ES,BX)   ; { Dos 2.1, 3.1, 3.2         }
  420.     DosCriticalStatus := ptr( ES,BX-1) ; { .. not true of 3.0        }
  421.   END {with}                           ;
  422.  
  423.       {───────────────────────────────────────────────────────────────}
  424.       { Search for Dos instruction that contains the INDOS stack addr }
  425.       { and the location of the critical flag. The critcal flag       }
  426.       { is NOT always in the word containing the InDosFlag.           }
  427.       { esp. in  Ver 3.0 . Search for instructions :                  }
  428.       {               cmp [CriticalFlag],00                           }
  429.       {               Jnz ...                                         }
  430.       {               Mov SP,IndosStackOfs                            }
  431.       {───────────────────────────────────────────────────────────────}
  432.  
  433.   Byteptr         := InDosStatus ;      { Search for instruction ... }
  434.   FoundInDosStack := false ;            { CMP [critical flag],00     }
  435.                                         { Mov SP,stackaddr           }
  436.   While (vec(Byteptr).ofs < $2000)
  437.      and (FoundInDosStack = false ) do begin
  438.  
  439.      if (word(Byteptr^) = $3E80) then            { Cmp byte ptr : CMP instctn }
  440.                                                  { found CMP instructn }
  441.                                                  { is next byte MOV SP,xx }
  442.         If byte(ptr(vec(Byteptr).seg,            { we have INDOS stack @  }
  443.                     vec(Byteptr).ofs+7)^) = $BC
  444.         then BEGIN                                    { InDos Stack address  }
  445.          vec(DosCriticalStatus).ofs :=                { get Crit.  flag ofs  }
  446.             word(ptr(vec(Byteptr).seg,
  447.                        vec(byteptr).ofs+2)^)        ;
  448.          InDosStackptr  := byteptr                  ; { set Stackptr segment }
  449.          vec(InDosStackptr).ofs :=
  450.                       word(ptr(vec(byteptr).seg,      { fetch true offset    }
  451.                             vec(byteptr).ofs+8)^)   ;
  452.          FoundInDosStack := true                    ;
  453.          END{if byte..begin}                        ;
  454.  
  455.      incptr(Byteptr,1)                              ; { examine next byte    }
  456.  
  457.   end{while bytptr < $2000}                         ;
  458.  
  459.      { Couldn't find critical flag CMP instruction or INDOS stack addr }
  460.  
  461.   If FoundInDosStack then {ok} else begin
  462.      Writeln('SR50 cannot find critical/stack instructions') ;
  463.      Writeln('SR50 incompatiblity with Operating System')    ;
  464.      Writeln('SR50 will not install correctly..Halting')     ;
  465.      Halt; end;
  466.  
  467.   for i := 1 to sizeof(borderchars) shr 1 do    { add attributes to array of }
  468.     borderchars[i] := borderchars[i] or $0700 ; { border making words        }
  469.  
  470.   if Lastmode = mono then videobuf := $b000
  471.      else videobuf := $B800                   ;
  472.  
  473.   end   { unit initialization } .
  474.