home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / STAYRESP.ZIP / STAYSUBS.410 < prev    next >
Encoding:
Text File  |  1986-06-13  |  15.3 KB  |  369 lines
  1. {****************************************************************************}
  2. {                         S T A Y S U B S  .  I N C                          }
  3. {****************************************************************************}
  4.       {---------------------------------------------------------}
  5.       {                 S E  T    D  T  A                       }
  6.       {---------------------------------------------------------}
  7.    Procedure SetDTA(var segment, offset : integer );
  8.    BEGIN
  9.      regs.ax := $1A00;      { Function used to get current DTA address }
  10.      regs.Ds := segment;    { Segment of DTA returned by DOS }
  11.      regs.Dx := offset;     { Offset of DTA returned }
  12.      MSDos( regs );         { Execute MSDos function request }
  13.    END;
  14.       {---------------------------------------------------------}
  15.       {                 G E  T    D  T  A                       }
  16.       {---------------------------------------------------------}
  17.    Procedure GetDTA(var segment, offset : integer );
  18.    BEGIN
  19.      regs.ax := $2F00;      { Function used to get current DTA address }
  20.      MSDos( regs );         { Execute MSDos function request }
  21.      segment := regs.ES;    { Segment of DTA returned by DOS }
  22.      offset  := regs.Bx;    { Offset of DTA returned }
  23.    END;
  24.       {---------------------------------------------------------}
  25.       {                 S E  T    P  S  P                       }
  26.       {---------------------------------------------------------}
  27.    Procedure SetPSP(var segment : integer );
  28.    BEGIN
  29.  
  30.        { A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack   }
  31.        { when the PSP get/set functions are issued at the DOS prompt. The  }
  32.        { following checks are made, forcing DOS to use the "critical"      }
  33.        { stack when the TSR enters at the INDOS level.                     }
  34.  
  35.                                       {If Version less then 3.0 and INDOS set }
  36.    If DosVersion < 3 then             { then set the Dos Critical Flag        }
  37.       If Mem[DosStat1.CS:DosStat1.IP] <> 0 then
  38.           Mem[DosStat2.CS:DosStat2.IP] := $FF;
  39.  
  40.      regs.ax := $5000;      { Function to set current PSP address }
  41.      regs.bx := segment;    { Segment of PSP to be used by DOS }
  42.      MSDos( regs );         { Execute MSDos function request }
  43.  
  44.                                       {If Version less then 3.0 and INDOS set }
  45.      If DosVersion < 3 then           { then clear the Dos Critical Flag     }
  46.         If Mem[DosStat1.CS:DosStat1.IP] <> 0 then
  47.            Mem[DosStat2.CS:DosStat2.IP] := $00;
  48.  
  49.    END;
  50.       {---------------------------------------------------------}
  51.       {                 G E  T    P  S  P                       }
  52.       {---------------------------------------------------------}
  53.    Procedure GetPSP(var segment : integer );
  54.    BEGIN
  55.  
  56.        { A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack   }
  57.        { when the PSP get/set functions are issued at the DOS prompt. The  }
  58.        { following checks are made, forcing DOS to use the "critical"      }
  59.        { stack when the TSR enters at the INDOS level.                     }
  60.  
  61.                                {If Version less then 3.0 and INDOS set }
  62.    If DosVersion < 3 then      { then set the Dos Critical Flag        }
  63.       If Mem[DosStat1.CS:DosStat1.IP] <> 0 then
  64.           Mem[DosStat2.CS:DosStat2.IP] := $FF;
  65.  
  66.      regs.ax := $5100;      { Function to get current PSP address }
  67.      MSDos( regs );         { Execute MSDos function request }
  68.      segment := regs.Bx;    { Segment of PSP returned by DOS }
  69.  
  70.                                 {IF DOS Version less then 3.0 and INDOS set }
  71.    If DosVersion < 3 then       { then clear the Dos Critical Flag     }
  72.       If Mem[DosStat1.CS:DosStat1.IP] <> 0 then
  73.            Mem[DosStat2.CS:DosStat2.IP] := $00;
  74.  
  75.    END;
  76.     {---------------------------------------------------------------}
  77.     {        G e t   C o n t r o l  C (break)  V e c t o r          }
  78.     {---------------------------------------------------------------}
  79. Type
  80.     Arrayparam = array [1..2] of integer;
  81. Const
  82.      SavedCtlC: arrayparam = (0,0);
  83.      NewCtlC  : arrayparam = (0,0);
  84.  Procedure GetCtlC(SavedCtlC:arrayparam);
  85.     Begin                     {Record the Current Ctrl-C Vector}
  86.        With Regs Do
  87.        Begin
  88.        AX:=$3523;
  89.        MsDos(Regs);
  90.        SavedCtlC[1]:=BX;
  91.        SavedCtlC[2]:=ES;
  92.        End;
  93.     End;
  94.     {---------------------------------------------------------------}
  95.     {        S e t   C o n t r o l  C   V e c t o r                 }
  96.     {---------------------------------------------------------------}
  97.     Procedure IRET;          {Dummy Ctrl-C routine}
  98.        Begin
  99.        inline($5D/$5D/$CF);  {Pop Bp/Pop Bp/Iret}
  100.        end;
  101.  Procedure SetCtlC(CtlCptr:arrayparam);
  102.     Begin                     {Set the New Ctrl-C Vector}
  103.        With Regs Do
  104.        Begin
  105.         AX:=$2523;
  106.         DS:=CtlCptr[2];
  107.         DX:=CtlCptr[1];
  108.         MsDos(Regs);
  109.        End;
  110.     End;
  111. {----------------------------------------------------------------------}
  112. {           K e y i n   :   R e a d  K e a b o a r d                   }
  113. {----------------------------------------------------------------------}
  114. Function Keyin: char;          { Get a key from the Keyboard           }
  115.    Var Ch : char;              { If extended key, fold above 127       }
  116.    Begin                       {---------------------------------------}
  117.       Repeat until Keypressed;
  118.       Read(Kbd,Ch);
  119.       if (Ch = Esc) and KeyPressed then
  120.          Begin
  121.          Read(Kbd,Ch);
  122.          Ch := Char(Ord(Ch) + 127);
  123.          End;
  124.       Keyin := Ch;
  125.    End;  {Keyin}
  126. {----------------------------------------------------------------------}
  127. {          B e e p   :  S o u n d  t h e  H o r n                      }
  128. {----------------------------------------------------------------------}
  129. Procedure Beep(N :integer); {------------------------------------------}
  130.    Begin                    {  This routine sounds a tone of frequency }
  131.       Sound(n);             {  N for approximately 100 ms              }
  132.       Delay(100);           {------------------------------------------}
  133.       Sound(n div 2);
  134.       Delay(100);
  135.       Nosound;
  136.       End {Beep} ;
  137.  
  138.       {--------------------------------------------------------------}
  139.       {                I N T E R R U P T    2 4                      }
  140.       {--------------------------------------------------------------}
  141. { Version 2.0, 1/28/86
  142.   -  Bela Lubkin
  143.      CompuServe 76703,3015
  144.  
  145.      Apologetically mangled by Lane Ferris
  146.  
  147.   For MS-DOS version 2.0 or greater, Turbo Pascal 1.0 or greater.
  148.  
  149.   Thanks to Marshall Brain for the original idea for these routines.
  150.   Thanks to John Cooper for pointing out a small flaw in the code.
  151.  
  152.   These routines provide a method for Turbo Pascal programs to trap
  153.   MS-DOS interrupt 24 (hex).  INT 24h is called by DOS when a 'critical
  154.   error' occurs, and it normally prints the familiar "Abort, Retry,
  155.   Ignore?" message.
  156.  
  157.   With the INT 24h handler installed, errors of this type will be passed
  158.   on to Turbo Pascal as an error.  If I/O checking is on, this will cause
  159.   a program crash.  If I/O checking is off, IOResult will return an error
  160.   code.  The global variable INT24Err will be true if an INT 24h error
  161.   has occurred.  The variable INT24ErrorCode will contain the INT 24h
  162.   error code as given by DOS. These errors can be found in the DOS
  163.   Technical Reference Manual.
  164.  
  165.   It is intended that INT24Result be used in place of IOResult. Calling
  166.   INT24Result clears IOResult.  The simple way to use INT24Result is just
  167.   to check that it returns zero, and if not, handle all errors the same.
  168.   The more complicated way is to interpret the code.  The integer
  169.   returned by INT24Result can be looked at as two bytes.  By assigning
  170.   INT24Result to a variable, you can then examine the two bytes:
  171.   (Hi(<variable>)-1) will give the DOS critical error code, or
  172.   (<variable> And $FF00) will return an integer from the table listed in
  173.   the INT24Result procedure (two ways of looking at the critical error);
  174.   Lo(<variable>) will give Turbo's IOResult.  A critical error will
  175.   always be reflected in INT24Result, but the IOResult part of
  176.   INT24Result will not necessarily be nonzero; in particular,
  177.   unsuccessful writes to character devices will not register as a Turbo
  178.   I/O error.
  179.  
  180.   INT24Result should be called after any operation which might cause a
  181.   critical error, if Turbo's I/O checking is disabled.  If it is enabled,
  182.   the program will be aborted except in the above noted case of writes to
  183.   character devices.
  184.  
  185.   Also note that different versions of DOS and the BIOS seem to react to
  186.   printer errors at vastly different rates.  Be prepared to wait a while
  187.   for anything to happen (in an error situation) on some machines.
  188.  
  189.   These routines are known to work correctly with: Turbo Pascal 1.00B PC-DOS;
  190.                                                    Turbo Pascal 2.00B PC-DOS;
  191.                                                    Turbo Pascal 2.00B MS-DOS;
  192.                                                    Turbo Pascal 3.01A PC-DOS.
  193.   Other MS-DOS and PC-DOS versions should work.
  194.  
  195.   Note that Turbo 2.0's normal IOResult codes for MS-DOS DO NOT
  196.   correspond to the I/O error numbers given in Appendix I of the Turbo
  197.   2.0 manual, or to the error codes given in the I/O error nn,
  198.   PC=aaaa/Program aborted message.  Turbo 3.0 IOResult codes do match the
  199.   manual.  Here is a table of the correspondence (all numbers in
  200.   hexadecimal):
  201.  
  202.   Turbo 2.0 IOResult    Turbo error, Turbo 3.0 IOResult
  203.   ------------------    -------------------------------------------------
  204.      00                 00  none
  205.      01                 90  record length mismatch
  206.      02                 01  file does not exist
  207.      03                 F1  directory is full
  208.      04                 FF  file disappeared
  209.      05                 02  file not open for input
  210.      06                 03  file not open for output
  211.      07                 99  unexpected end of file
  212.      08                 F0  disk write error
  213.      09                 10  error in numeric format
  214.      0A                 99  unexpected end of file
  215.      0B                 F2  file size overflow
  216.      0C                 99  unexpected end of file
  217.      0D                 F0  disk write error
  218.      0E                 91  seek beyond end of file
  219.      0F                 04  file not open
  220.      10                 20  operation not allowed on a logical device
  221.      11                 21  not allowed in direct mode
  222.      12                 22  assign to standard files is not allowed
  223.      --                 F3  Too many open files
  224.  
  225.   -  Bela Lubkin
  226.      CompuServe 76703,3015
  227.      1/28/86
  228. }
  229.  
  230. Const
  231.   INT24Err: Boolean=False;
  232.   INT24ErrCode: Byte=0;
  233.   OldINT24: Array [1..2] Of Integer=(0,0);
  234.  
  235. Var
  236.   RegisterSet: Record Case Integer Of
  237.                  1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
  238.                  2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
  239.                End;
  240.  
  241. Procedure INT24;     { Interrupt 24 Service Routine }
  242.   Begin
  243.  
  244.     Inline( $2E/$C6/$06/ Int24Err / $01/$50/$89/$F8/$2E/$A2/ Int24ErrCode
  245.             /$58/$B0/$00/$89/$EC/$5D/$CF);
  246.  
  247. {   Turbo:  PUSH BP                    Save caller's stack frame
  248.             MOV  BP,SP                  Set up this procedure's stack frame
  249.             PUSH BP                     ?
  250.     Inline:
  251.             MOV  BYTE CS:[INT24Err],1   Set INT24Err to True
  252.             PUSH AX
  253.             MOV  AX,DI                  Get INT 25h error code
  254.             MOV  CS:[INT24ErrCode],AL   Save it in INT24ErrCode
  255.             POP  AX
  256.             MOV  AL,0                   Tell DOS to ignore the error
  257.             MOV  SP,BP                  Unwind stack frame
  258.             POP  BP
  259.             IRET                        Let DOS handle it from here
  260. }
  261.   End;
  262.  
  263.        {------------------------------------------------------------}
  264.        {       I N T  2 4   O N                                     }
  265.        {------------------------------------------------------------}
  266.             { Grab the Critical error ptr from the previous user}
  267. Procedure INT24On;  { Enable INT 24h trapping }
  268.   Begin
  269.     INT24Err:=False;
  270.     With RegisterSet Do
  271.      Begin
  272.       AX:=$3524;
  273.       MsDos(RegisterSet);
  274.  
  275.       If (OldINT24[1] Or OldINT24[2])=0 Then
  276.        Begin
  277.         OldINT24[1]:=ES;
  278.         OldINT24[2]:=BX;
  279.        End;
  280.       DS:=CSeg;
  281.       DX:=Ofs(INT24);
  282.       AX:=$2524;
  283.       MsDos(RegisterSet);
  284.      End;
  285.   End;
  286.        {------------------------------------------------------------}
  287.        {                 I N T  2 4   O F F                         }
  288.        {------------------------------------------------------------}
  289.          { Give Critical Error Service pointer back to previous user }
  290. Procedure INT24Off;
  291.   Begin
  292.     INT24Err:=False;
  293.     If OldINT24[1]<>0 Then
  294.       With RegisterSet Do
  295.        Begin
  296.         DS:=OldINT24[1];
  297.         DX:=OldINT24[2];
  298.         AX:=$2524;
  299.         MsDos(RegisterSet);
  300.        End;
  301.     OldINT24[1]:=0;
  302.     OldINT24[2]:=0;
  303.   End;
  304.  
  305. Function INT24Result: Integer;
  306.   Var
  307.     I:Integer;
  308.  
  309.   Begin
  310.     I:=IOResult;
  311.     If INT24Err Then
  312.      Begin
  313.       I:=I+256*Succ(INT24ErrCode);
  314.       INT24On;
  315.      End;
  316.     INT24Result:=I;
  317.   End;
  318.  
  319. { INT24Result returns all the regular Turbo IOResult codes if no critical
  320.   error has occurred.  If a critical error, then the following values are
  321.   added to the error code from Turbo:
  322.    256:  Attempt to write on write protected disk
  323.    512:  Unknown unit                 [internal dos error]
  324.    768:  Drive not ready              [drive door open or bad drive]
  325.    1024: Unknown command              [internal dos error]
  326.    1280: Data error (CRC)             [bad sector or drive]
  327.    1536: Bad request structure length [internal dos error]
  328.    1792: Seek error                   [bad disk or drive]
  329.    2048: Unknown media type           [bad disk or drive]
  330.    2304: Sector not found             [bad disk or drive]
  331.    2560: Printer out of paper         [anything that the printer might signal]
  332.    2816: Write fault                  [character device not ready]
  333.    3072: Read fault                   [character device not ready]
  334.    3328: General failure              [several meanings]
  335.  
  336.   If you need the IOResult part, use
  337.    I:=INT24Result and 255; [masks out the INT 24h code]
  338.  
  339.   For the INT 24h code, use
  340.    I:=INT24Result Shr 8;   [same as Div 256, except faster]
  341.  
  342.   INT24Result clears both error codes, so you must assign it to a variable if
  343.   you want to extract both codes:
  344.    J:=INT24Result;
  345.    WriteLn('Turbo IOResult  = ',J And 255);
  346.    WriteLn('DOS INT 24h code = ',J Shr 8);
  347.  
  348.   Note that in most cases, errors on character devices (LST and AUX) will not
  349.   return an IOResult, only an INT 24h error code. }
  350.  
  351. { Main program.  Delete next line to enable }
  352.  
  353.        {---------------------------------------------------------}
  354.        {            G E T    E R R O R    C O D E                }
  355.        {---------------------------------------------------------}
  356.    Procedure GetErrorCode;
  357.     Begin
  358.     Error := IOresult;                  {Read the I/O result}
  359.  
  360.     If INT24Err Then
  361.      Begin
  362.       Error:=Error+256*Succ(INT24ErrCode);
  363.       INT24On;
  364.      End;
  365.     Good := (Error = 0);                {Set Boolean Result }
  366.   End;
  367.  
  368.   {--------------------------------------------------------------}
  369.