Power-Programmierung/CD1.mdf/pascal/utility/crossref/pxl/pxlinit.pas

Pascal/Delphi Source File | 1988-05-04 | 38.5 KB | 1,094 lines

{$R-}    {Range checking off}                                          {.CP5}
{$B-}    {Boolean complete evaluation off}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}

Unit PXLINIT;

Interface

Uses
  Crt,
  Dos;

const                                                                  {.CP9}
   StdLineWidth   = 80;
   ScreenSize     = 2000;
   Triggers: set of char = [#27,#3];
   NoIncFiles = 8;
   BoxT =  5;
   BoxB = 21;
   BoxL = 10;
   BoxR = 70;

type                                                                  {.CP25}
   ColType      =  record                    {These 3 make a scrn size array}
                      case boolean of        {Addressed like BASIC'S screen }
                         True:  (C,A: byte); {[Row,Col].C = char            }
                         False: (I: word)    {[Row,Col].A = attribute       }
                   end;                      {[Row,Col].I = both, but with  }
   RowType      =  array[1..80] of ColType;  {   attribute in hi byte       }
   ScrType      =  array[1..25] of RowType;  {   character in lo byte       }
   ScrPtrType   =  ^ScrType;
   MonitorType  =  (MDA,CGA,EGA);
   LineType     =  string[StdLineWidth];
   CharSet      =  set of char;
   TpFace   = (MrkB,MrkE,EliteB,EliteE,CondB,CondE,FF);
   ByteLine = array[0..3] of byte;
   Bytes    = array[MrkB..FF] of Byteline;
   Fil      = file of ByteLine;
   Str255   = string[255];
   CMD      = string[128]; {For command line}
   Str20    = string[20];
   Str10    = string[10]; {Must be large enough for longest reserved word}
   Str9     = string[9];
   Str5     = string[5];
   Str4     = string[4];
   Str3     = string[3];
   str2     = string[2];
   ResArr   = array[1..100] of Str20;

var                                                                   {.CP20}
   CRTube:    ScrPtrType;  {Set to point at real screen buffer}
   CRTAddr:   array[1..2] of word absolute CRTube;
   Monitor:   MonitorType;
   OrigAtt:   byte;
   BlnkLn:    LineType;
   Scr:                ScrType;
   C:                  char;
   Inside,
   BottomMargin,
   MaxLin,
   NormalColor,
   FrameColor,
   Background,
   Bright,Dim:         byte;
   F,Lst:              text;
   IFil:               array[1..NoIncFiles] of text;
   IFileName:          array[1..NoIncFiles] of LineType;
   IFN:                1..NoIncFiles;
   PathSign,
   FileName:           LineType;
   Opening,Closing:    Str3;                                          {.CP22}
   PrintDate,
   FileDate:           Str20;
   PrintTime,
   FileTime:           Str10;
   UserID:             string[25];
   Number:             string[16];
   Line:               Str255;
   Day,I,LineNumber,
     PageLineNumber,
     Page,Year,NRes:  integer;
   ScrSeg:             word;
   GotPrnData,Plain,
     Mrk,XRef,Wide,
     XRefOnly,Enough,
     NumberLines,
     InABatch,FFeed,
     DataFiles:        boolean;
   Inst:               Bytes;
   T:                  TpFace;
   Istring:            array[MrkB..CondE] of Str3;
   Reserv:             ResArr;
   OutputDevice:       string[14];
   Command:            CMD;

procedure Bip;
procedure Beep;
procedure Bop;
procedure ToScrn(var S: ScrType);
procedure FromScrn(var S: ScrType);
procedure FillWd(Segm,Offst,Num,Wd: word);
procedure FillOdd(Segm,Offst,Num: integer; Bt: byte);
procedure SkipMove(var From,Target; Num: word);
procedure GetScreen;
procedure WipeSlate(var S: ScrType; Clr: byte);
procedure Rectangle(var S: ScrType; R1,C1,R2,C2,Att,Vert,Hor: byte);
procedure WriteIt(var Scr: ScrType; Str: LineType; R,C,Color: byte);
procedure WriteCRT(Str: LineType; Row,Col,Att: byte);
procedure CenterCRT(S: LineType; Row,Attrib,Width: byte);
procedure Center(var Scr: ScrType; Str: LineType; Line,Color,Width: byte);
function CurrentAttribute: byte;
procedure CursorOff; {invisible but present}
procedure CursorOn;
procedure RestoreScreen;
procedure SetErrorLevel(Level: byte);
procedure SetScrAtt(Att: byte);

function IsIntense(A: byte): boolean;
function Intensified(A: byte): byte;
function Dimmed(A: byte): byte;
function IsBlinking(A: byte): boolean;
function Blinking(A: byte): byte;
function UnBlinking(A: byte): byte;
function BlackBackground(A: byte): boolean;
function BlackForeground(A: byte): boolean;
function BackgroundOf(A: byte): byte;
function ForegroundOf(A: byte): byte;
function InverseOf(A: byte): byte;
function CombinedAttributeOf(F,B: byte): byte;

function PadOrChop(L: LineType; Len: byte):LineType;
procedure Replace(This,WithThat: LineType; var TheLine: LineType);

function StrgB(B,L: Byte): LineType;
function StrgR(R: real;L1,L2: Byte): LineType;
function StrgI(B,L: Integer): Str9;
function Strip(L: LineType; NoNo: CharSet): LineType;
function InCapitals(L: LineType): LineType;

function KbIn(var Extended: boolean): char;
function EditTrm(N: byte): LineType;

function CurrentDriveAndDirectory: LineType;
   {Returns full current drive:\directory}

function EnvironLine(LineStart: LineType): LineType;                   {.CP3}
   {Searches DOS environment for line beginning with LineStart}
   {If found, returned in EnvironLine.  If not returns "NONE"}
function FindFile(var FName: LineType): boolean;                       {.CP4}
   {Takes File name.  Searches for file on default drive & along DOS PATH. }
   {Reports success or failure in FindFile.                                }
   {If file is found, returns openable FName with successful path prefixed.}
procedure CloseCarefully(var F: text);

function Escape: boolean;                                              {.CP3}
{  Empties the keyboard buffer & returns False if no trigger}
{  Does not wait for a keypress}

procedure Blank(Top,Bot: integer);
procedure ByeBye;
procedure GetOutOfHere;
procedure PXLRectangle;
procedure CantCont(FilNam,Comment: LineType);
procedure GetPrinterData;                                              {.CP3}
{If constant DataFiles is True, this procedure loads printer control }
{symbols from PXL.PRN.  If it's false, they're set here.             }
function DefaultDrive: char; {Returns letter of Default Drive}
procedure FixUpFileName(Var FilNam: LineType);
function Shortened(FileName: LineType): Str20;

{===========================================================================}

Implementation

procedure Bip;                                                         {.CP5}
begin
   sound(1760); delay(10); sound(440); delay(30);
   sound(1760); delay(15); nosound
end;

procedure Beep;                                                        {.CP4}
begin
   sound(456);
end; {Beep}

procedure Bop;                                                         {.CP4}
begin
   delay(100); nosound; delay(150); sound(362); delay(400); nosound;
end; {Bop}

procedure ToScrn;                                                     {.CP14}
const
   ScrnPort        = $3D8;           {for CGA board}
   On              =  45;            {for ScrnPort}
   Off             =   5;
begin
   if Monitor=CGA then begin
      Port[ScrnPort] := Off;
      CRTube^ := S;
      Port[ScrnPort] := On
   end {if CGA}
   else
      CRTube^ := S
end; {ToScrn}

procedure FromScrn;                                                   {.CP14}
const
   ScrnPort        = $3D8;           {for CGA board}
   On              =  45;            {for ScrnPort}
   Off             =   5;
begin
   if Monitor=CGA then begin
      Port[ScrnPort] := Off;
      S := CRTube^;
      Port[ScrnPort] := On
   end {if CGA}
   else
      S := CRTube^
end; {FromScrn}

procedure FillWd;                                                     {.CP18}
{ Like FillChar but fills with 2-byte integers.  Here declared:      }
{      procedure FillWd(Segm,Offst,Num,Wd: integer)                  }
{ Can also be declared:                                              }
{      procedure FillWd(var S; Num,Wd: integer)                      }
begin
   inline
                  {FILLWD PROC NEAR                                  }
                  {       INLINE                                     }
   ($C4/$7E/$0A/  { <     les  di, 08H[bp] ; load di and ds at once  }
                  {                                                  }
   $8B/$4E/$08/   { <     MOV  CX,6[BP]    ; Num                     }
   $8B/$46/$06/   { <     MOV  AX,4[BP]    ; Wd                      }
                  {                                                  }
   $FC/           {       cld              ;8088 ==> autoincrement   }
   $F3/           {       rep              ;store CX copies of AX in }
   $AB)           {       stosw            ; ES:[DI] (not DS:[DI])   }
end; {FillWd}

procedure FillOdd;                                                    {.CP21}
   {Turbo Pascal INLINE procedure like FillChar but skips even bytes in }
   {target.  Use it To write without coloring or color without writing. }
   {Here declared:                                                      }
   {   procedure FillOdd(Segm,Offst,Num: integer; Bt: byte);            }
   {Can also be declared:                                               }
   {   procedure FillWd(var V; Num, integer; Bt: byte);                 }
begin                  {       INLINE                                   }
   inline(             {FILLWD PROC NEAR                                }
   $1E/                {       PUSH DS          ; Save DS               }
   $8E/$5E/$0C/        {       MOV  DS,0AH[BP]  ; Segm                  }
   $8B/$7E/$0A/        {       MOV  DI,8H[BP]   ; Offst                 }
   $8B/$4E/$08/        {       MOV  CX,6H[BP]   ; Num                   }
   $29/$C0/            {       SUB  AX,AX                               }
   $8A/$46/$06/        {       MOV  AL,4H[BP]   ; Bt                    }
   $88/$05/            {START  MOV  [DI],AL     ; Put Bt in target      }
   $47/                {       INC  DI          ; Shift target          }
   $47/                {       INC  DI          ;  twice                }
   $E2/$FA/            {       LOOP START       ; Loop CX (Num) times   }
   $1F)                {       POP  DS          ; Restore DS            }
end; {FillOdd}         {       ENDP                                     }

procedure SkipMove;                                                   {.CP27}
  {Moves Num bytes from source to Target, skipping bytes in Target.     }
  {Could write to screen w/o coloring. (Beware: can't handle overlap).  }
  {Here declared:                                                       }
  {   procedure SkipMove(var From,Target; Num: integer);                }
  {Can also be declared:                                                }
  {   procedure SkipMove(SegS,OffS,SegT,OffT,Num: integer);             }
begin                   {                                               }
   inline(              {       inline                                  }
                        {FILLWD PROC NEAR                               }
   $1E/                 {       push ds                                 }
   $8E/$46/$0E/         {       mov  es,0ch[bp]  ;SegS                  }
   $8B/$76/$0C/         {       mov  si,0ah[bp]  ;OffS                  }
                        {                                               }
   $8E/$5E/$0A/         {       MOV  DS,08H[BP]  ; SegT                 }
   $8B/$7E/$08/         {       MOV  DI,06H[BP]  ; OffT                 }
   $28/$ED/             {       sub  ch,ch                              }
   $8A/$4E/$06/         {       MOV  CL,04h[BP]    ; Num in CX          }
                        {                                               }
   $26/$8A/$04/         {START  mov  al,es:[si]  ; Get byte from source }
   $88/$05/             {       MOV  [DI],al     ; Put byte in target   }
   $47/                 {       INC  DI          ; Shift target         }
   $47/                 {       INC  DI          ;  twice               }
   $46/                 {       inc  si          ; Shift source once    }
   $E2/$F6/             {       LOOP START       ; Loop CX (Num) times  }
   $1F)                 {       POP  DS          ; Restore DS           }
end; {SkipMove}         {       ENDP                                    }

procedure GetScreen;                                                  {.CP13}

   function MonitorIsEGA: boolean;
   var
      R: Registers;
   begin
     with R do begin
        AH := $12;
        BX := $FF10;
        intr($10,R);
        MonitorIsEga := BH<>$FF
     end {with}
  end; {MonitorIsEGA}

begin                                                                 {.CP12}
   if (Lo(LastMode)=7) then begin
      CRTube := Ptr($B000,0000);
      Monitor := MDA;
   end {if mode 7}
   else begin
      CRTube := Ptr($B800,0000);
      if MonitorIsEGA
         then Monitor := EGA
         else Monitor := CGA
   end {else not 7}
end; {GetScrn}

procedure WipeSlate;                                                   {.CP8}
{Set attributes all to same color)}
var
   Filler:    integer;
begin
   Filler := (Clr shl 8) + $20;
   FillWd(seg(S),ofs(S),2000,Filler);
end; {WipeSlate}

procedure Rectangle;                                                  {.CP11}
{R1,C1 is row & col of upper left corner, R2,C2 is lower right      }
{Vert is single or double vert char, Hor is single or 2ble horizontal}
const
   OK: set of byte = [1..2];
type
   Rchars = (Hr,Vr,UL,UR,LL,LR);
var
   Element: array[Hr..LR] of byte;
   Row:     byte;
   Filler:  integer;
begin                                                                 {.CP20}
   if not (Hor in OK) then Hor := 1;
   if not (Vert in OK) then Vert := 1;
   if Vert=1 then begin
      Element[Vr] := 179;
      if Hor=1 then begin
         Element[Hr] := 196;       {V1 H1}
         Element[UL] := 218;
         Element[UR] := 191;
         Element[LL] := 192;
         Element[LR] := 217;
      end {if Hor=1}
      else if Hor=2 then begin    {V1 H2}
         Element[Hr] := 205;
         Element[UL] := 213;
         Element[UR] := 184;
         Element[LL] := 212;
         Element[LR] := 190;
       end {if Hor=2}
   end {if V1}
   else begin                                                         {.CP17}
      Element[Vr] := 186;
      if Hor=1 then begin
         Element[Hr] := 196;       {V2 H1}
         Element[UL] := 214;
         Element[UR] := 183;
         Element[LL] := 211;
         Element[LR] := 189;
      end {if Hor=1}
      else if Hor=2 then begin    {V2 H2}
         Element[Hr] := 205;
         Element[UL] := 201;
         Element[UR] := 187;
         Element[LL] := 200;
         Element[LR] := 188;
       end {if Hor=2}
   end; {else Ver=2}

   Filler := Att shl 8 + Element[Hr];                                 {.CP4}
   FillWd(seg(S[R1,C1].I),ofs(S[R1,C1].I),succ(C2-C1),Filler);
   FillWd(seg(S[R2,C1].I),ofs(S[R2,C1].I),succ(C2-C1),Filler);
   Filler := Att shl 8 + Element[Vr];

   for Row := succ(R1) to pred(R2) do begin                           {.CP4}
      S[Row,C1].I  := Filler;
      S[Row,C2].I  := Filler
   end; {for Row}

   S[R1,C1].I  := Att shl 8 + Element[UL];                            {.CP5}
   S[R2,C1].I  := Att shl 8 + Element[LL];
   S[R1,C2].I  := Att shl 8 + Element[UR];
   S[R2,C2].I  := Att shl 8 + Element[LR];
end; {Rectangle}

procedure WriteIt;                                                    {.CP6}
{R is row; C is column in which to start.}
begin
   FillWd(Seg(Scr[R,C]),Ofs(Scr[R,C]),ord(Str[0]),succ(Color shl 8));
   SkipMove(Str[1],Scr[R,C],ord(Str[0]));
end; {WriteIt}

procedure WriteCRT;                                                   {.CP4}
 { Writes characters quickly to the screen starting at Row, Col, }
 { using attribute Att.  Detects presence of Text or CGA board.  }
 { If it finds a CGA, chars are snuck in during vertical retrace }
 { to avoid snow. }
begin
   inline(      {         INLINE ; CHASM's famous Turbo feature  }    {.CP29}
                {WRITECRT PROC FAR                               }
   $1E/         {         PUSH DS                                }
   $1E/         {         PUSH DS                                }
   $8A/$46/$0A/ {         MOV  AL,08H[BP]     ; Row.             }
   $FE/$C8/     {         DEC  AL             ; Make top Row 1   }
   $B3/$50/     {         MOV  BL,80                             }
   $F6/$E3/     {         MUL  BL                                }
   $29/$DB/     {         SUB  BX,BX                             }
   $8A/$5E/$08/ {         MOV  BL,06H[BP]     ; Col              }
   $FE/$CB/     {         DEC  BL             ; Make 1st Col 1   }
   $01/$D8/     {         ADD  AX,BX                             }
   $01/$C0/     {         ADD  AX,AX                             }
   $8B/$F8/     {         MOV  DI,AX                             }
   $8A/$7E/$06/ {         MOV  BH,04H[BP] ; Attrib into BH       }
   $8E/$46/$0E/ {         MOV  ES,0CH[BP] ; Str SEG -> ES        }
   $8B/$76/$0C/ {         MOV  SI,0AH[BP] ; Str OFS -> SI        }
   $29/$C9/     {         SUB  CX,CX ; Addr of Str now in ES:SI  }
   $26/$8A/$0C/ {         MOV  CL,ES:[SI] ; Length of Str in CX  }
   $29/$C0/     {         SUB  AX,AX   ; See if graphix or mono  }
   $8E/$D8/     {         MOV  DS,AX                             }
   $3E/$A0/$49/$04/ {     MOV  AL,DS:[449H]                      }
   $1F/         {         POP  DS                                }
   $20/$C9/     {         AND  CL,CL ; If length(Str)=0 then done}
   $74/$26/     {         JZ   DONE                              }
   $BA/$00/$B0/ {         MOV  DX,0B000H      ; For MONO         }
   $8E/$DA/     {         MOV  DS,DX                             }
   $2C/$07/     {         SUB  AL,7                              }
   $74/$12/     {         JZ   GETCHAR                           }

   $BA/$00/$B8/ {GRAPHICS MOV  DX,0B800H ; Load display mem      }     {.CP9}
   $8E/$DA/     {         MOV  DS,DX   ;    into DS              }
   $BA/$DA/$03/ {         MOV  DX,3DAH ; Status port CGA board   }
   $EC/         {TESTLOW  IN   AL,DX   ; Await vert retr (Test 8)}
   $A8/$08/     {         TEST AL,8    ; (This code found in     }
   $75/$FB/     {         JNZ  TESTLOW ; Tech Ref Man BIOS listg)}
   $EC/         {TESTHI   IN   AL,DX                             }
   $A8/$08/     {         TEST AL,8                              }
   $74/$FB/     {         JZ   TESTHI                            }

   $46/         {GETCHAR  INC  SI     ; Point at next char in Str}     {.CP8}
   $26/$8A/$1C/ {         MOV  BL,ES:[SI] ; Get char into BL     }
   $3E/$89/$1D/ {         MOV  DS:[DI],BX ; Write wd into target }
   $47/         {         INC  DI         ; Shift aim            }
   $47/         {         INC  DI         ;   by 2 bytes         }
   $E2/$F5/     {         LOOP GETCHAR ; CX times (len of string)}

   $1F)         {DONE     POP  DS                                }
end; {WriteCRT} {         ENDP                                   }

procedure CenterCRT;                                                   {.CP8}
begin
   if Width >0 then begin
      BlnkLn[0] := char(Width);
      WriteCRT(BlnkLn,Row,41-(ord(BlnkLn[0]) div 2),Attrib);
   end; {if Width}
   WriteCRT(S,Row,41-(ord(S[0]) div 2),Attrib)
end;

procedure Center;                                                     {.CP13}
var
   StartCol:   byte;
   Filler:     integer;
begin
   if Width>0 then begin
      Filler := (Color shl 8) + $20;
      StartCol := 41 - (Width div 2);
      FillWd(seg(Scr),ofs(Scr[Line,StartCol]),Width,Filler);
   end; {if Width}
   StartCol := 41 - (ord(Str[0]) div 2);
   WriteIt(Scr,Str,Line,StartCol,Color)
end; {Center}

function CurrentAttribute;                                            {.CP12}
var
   R:    DOS.Registers;
begin
   GotoXY(1,pred(WhereY));
   with R do begin
      AH := $08;
      BH := 0;
      Intr($10,R);
      CurrentAttribute := AH
   end {with R}
end; {CurrentAttribute}

procedure CursorOff;                                                   {.CP9}
var
   R:    Registers;
begin
   R.AH := 1;
   R.CH := $20;
   R.CL := 0;
   intr($10,R)
end; {CursorOff}

procedure CursorOn;                                                   {.CP21}
var
   R:    Registers;
begin
   with R do begin {Make standard 2-line cursor}
      AH := 1;      {Make Cursor }
      if Monitor=CGA then begin
         CH := 6;   {top line 6}
         CL := 7;   {bot line 7}
      end {if CGA}
      else if Monitor=EGA then begin
         CH := 7;   {top line 7}
         CL := 10;  {bot line 10}
      end {else if EGA}
      else begin
         CH := 12;  {top 12}
         CL := 13;  {bot 13}
      end; {else MDA}
   end; {with R}
   Intr($10,R);    {BIOS Video service}
end; {CursorOn}

procedure RestoreScreen;                                              {.CP19}
{ Put screen back politely (if A is the atribute found by CurrentAttribute  }
{ on entry).  Scrolls up one line to set color, but does not overwrite any- }
{ other part of the screen.  Makes standard 2-line DOS cursor, placed at    }
{ bottom of the screen.                                                     }
var
   Filler:    integer;
   R:         Registers;
begin
   CursorOn;
   GotoXY(1,24);
   with R do begin {Scroll up one line at bottom of screen coloring   }
      AX := $0601;    {BIOS Video Svc 6 in AH, 1 line to scroll in AL }
      CX := $1700;    {Top row 23 in CH, Lft col 0 in CL }
      DX := $184F;    {Bot row 24 in CH, Rt col 79 in CL }
      BH := OrigAtt;        {Attribute in BH }
   end; {with R}
   Intr($10,R);    {BIOS Video service}
end; {RestoreScreen}

procedure SetErrorLevel(Level: byte);                                 {.CP21}
{Uses DOS function $4C to terminate, setting error level for DOS batch   }
{file to read.  Checks for DOS 2 or higher --$4C would crash DOS 1.10-.  }
{Since $4C also terminates program, handle like halt statement.  Be care-}
{ful.  If run from Turbo, it will terminate Turbo.                       }
var
   Regs:      Registers;
begin
   RestoreScreen;
   with Regs do begin
      AH := $30;                                            {Get DOS version}
      MsDos(Regs);                              {0 in AL if DOS 1.00 or 1.10}
      if AL>0 then begin                {if DOS 2 or higher, set error level}
         AL := Level;                                {--DOS 1 crashes on $4C}
         AH := $4C;                           {Terminate setting error level}
         MsDos(Regs)
      end {if AL>0}
      else
         halt
   end; {with Regs}
end; {SetErrorLevel}

procedure SetScrAtt;                                                   {.CP5}
{Set Turbo's internal variable}
begin
   TextAttr := Att;
end; {SetScrAtt}

function IsIntense;                                                    {.CP4}
begin
   IsIntense := (A and 8)=8
end; {IsDim}

function Intensified;                                                  {.CP4}
begin
   Intensified := A or 8;
end; {Intensified}

function Dimmed;                                                       {.CP4}
begin
   Dimmed := A and 247
end; {Dimmed}

function IsBlinking;                                                   {.CP4}
begin
   IsBlinking := (A and 128)=128
end; {IsBlinking}

function Blinking;                                                     {.CP4}
begin
   Blinking := A or 128
end; {Blinking}

function UnBlinking;                                                   {.CP4}
begin
   UnBlinking := A and 127;
end; {UnBlinking}

function BlackBackground;                                              {.CP4}
begin
   BlackBackground := (A and 112)=0
end; {BlackBackground}

function BlackForeground;                                              {.CP4}
begin
   BlackForeground := (A and 7)=0
end; {BlackForeground}

function BackgroundOf;                                                 {.CP4}
begin
   BackgroundOf := (A and 112) shr 4
end; {BackgroundOf}

function ForegroundOf;                                                 {.CP5}
{including intensity}
begin
   ForegroundOf := A and 15
end; {ForegroundOf}

function InverseOf;                                                    {.CP6}
{Switch background & foreground, preserving intensity}
begin
   InverseOf := (A and 128) + ((A and 112) shr 4)
                + (A and 8) + ((A and 7) shl 4)
end; {InverseOf}

function CombinedAttributeOf;                                          {.CP5}
{Intensity follows F(oreground); ignores blinking.}
begin
   CombinedAttributeOf := ((B and 7) shl 4) or (F and 15)
end; {CombinedAttributeOf}

function PadOrChop(L: LineType; Len: byte):LineType;                   {.CP6}
begin
   while L[0]<char(Len) do L := L + #32;
   if L[0]>char(Len) then L[0] := char(Len);
   PadOrChop := L;
end; {PadOrChop}

procedure Replace; {(This,WithThat: LineType; var TheLine: LineType); {.CP11}
var
   P,K: integer;
begin
   P := pos(This,TheLine);
   while P>0 do begin
      for K := 1 to ord(This[0]) do delete(TheLine,P,1);
      insert(WithThat,TheLine,P);
      P := pos(This,TheLine);
   end; {while P>0}
end; {Replace}

function StrgB;                                                        {.CP7}
var
   S: LineType;
begin
   str(B:L,S);
   StrgB := S
end; {StrgB}

function StrgR;                                                        {.CP7}
var
   S: LineType;
begin
   str(R:L1:L2,S);
   StrgR := S
end; {StrgR}

function StrgI;                                                        {.CP7}
   var
   S: LineType;
begin
   str(B:L,S);
   StrgI := S
end; {StrgB}

function Strip;                                                        {.CP7}
{remove leading & trailing junk (list comes in  NoNo)}
begin {Strip}
   while (L[0]>#0) and (L[1] in NoNo) do delete(L,1,1);
   while L[ord(L[0])] in NoNo do L[0] := pred(L[0]);
   Strip := L
end; {Strip}

function InCapitals;                                                   {.CP7}
var
   K:              byte;
begin {InCapitals}
   for K := 1 to ord(L[0]) do L[K] := UpCase(L[K]);
   InCapitals := L
end; {InCapitals}

function KbIn;                                                        {.CP15}
var
   C:              char;
   N:              integer;
   R:              DOS.Registers;
begin
   C := ReadKey;
   if C<>#0 then
      Extended := False
   else begin
      Extended := True;
      C := ReadKey
   end; {else}
   KbIn := C;
end; {KbIn}

function EditTrm;                                                      {.CP8}
const
   Outs: set of char = [#3,#13,#27];
var
   C:         char;
   S:         LineType;
   Ext:       boolean;
   X,Y:       byte;

   procedure DeleteOne;                                                {.CP9}
   begin
      if length(S)>0 then begin
         delete(S,length(S),1);
         write(#8,#32,#8)
      end {if length>0}
      else
         Bip
   end; {DeleteOne}

begin {EditTrm}                                                       {.CP21}
   S := '';
   CursorOn;
   repeat
      X := WhereX; Y := WhereY;
      C := Kbin(Ext);
      GotoXY(X,Y);
      if Ext then
         if C='K'                                                {back-arrow}
            then DeleteOne
            else bip                            {beep for improper keystroke}
      else if C=#8 then
         DeleteOne
      else if (C=#27) or (C=#3) then
         S := #27
      else if C<>#13 then begin
         S := S + C;
         write(C)
      end; {if}
   until (length(S)>=N) or (C in Outs);
   EditTrm := S;
   CursorOff
end; {EditTrm}

function CurrentDriveAndDirectory;                                      {.CP8}
{Returns full current drive:\directory}
{Needs types: LineType, DOS.Registers}
var
   Data: array[1..64] of char;
   Regs: DOS.Registers;
   Bt:  byte;
   S:    LineType;

   function CurrentDrive: byte;                                         {.CP9}
   {Returns 0 for A:, 1 for B:, etc.}
   var
      Regs: DOS.Registers;
   begin
      Regs.AH := $19;
      MsDos(Regs);
      CurrentDrive := Regs.AL
   end; {CurrentDrive}

begin                                                                  {.CP17}
   Bt := CurrentDrive;
   with Regs do begin
      AH := $47;
      DL := succ(Bt);
      DS := Seg(Data);
      SI := Ofs(Data);
      MsDos(Regs);
   end; {with Regs}
   S := char(Bt+65) + ':\';
   Bt := 1;
   while Data[Bt]<>#0 do begin
      S := S + UpCase(Data[Bt]);
      Bt := succ(Bt)
   end; {while}
   CurrentDriveAndDirectory := S
end; {CurrentDriveAndDirectory}

function EnvironLine;                                                  {.CP30}
{ Searches DOS Environment for line beginning with LineStart        }
{ Returns line with LineStart removed it in EnvironLine if found.   }
{ Returns "NONE" if not found. }
var
   S:               LineType;
   EnvAdd:          word;
   B:               byte;
   LineFound:       boolean;
begin
   EnvAdd := MemW[PrefixSeg:$2C];
   B := 0;
   LineFound := False;
   LineStart := InCapitals(LineStart);
   repeat
      S := '';
      while Mem[EnvAdd:B]<>0 do begin
         S := S + UpCase(char(Mem[EnvAdd:B]));
         B := succ(B)
      end; {while}
      if pos(LineStart,S)=1 then begin
         delete(S,1,ord(LineStart[0]));
         while S[1] in [' ','='] do delete(S,1,1);
         EnvironLine := S;
         LineFound := True
      end; {if PATH}
      B := succ(B)
   until (S[0]=#0) or LineFound;
   if not LineFound then EnvironLine := 'NONE'
end; {EnvironLine}

function FindFile;                                                      {.CP9}
{Takes File name.  Searches for file on default drive & along DOS PATH.  }
{Reports success or failure in FindFile.                                 }
{If file is found, returns openable FName with successful path prefixed. }
var
   Paths,
   Try:       LineType;
   F:         text;   {File type doesn't matter.  File only reset, not read.}
   GotIt:     boolean;

   function Path(var P: LineType): LineType;                          {.CP15}
   {Takes DOS PATH line and peels one path specifier from it.  }
   {Returns specifier in Path, bobtailed DOS PATH line in P.   }
   var
      Chunk:     LineType;
   begin
      Chunk := '';
      while (P[1]<>';') and (P[0]<>#0) do begin
         Chunk := Chunk + P[1];
         delete(P,1,1)
      end; {while not ";"}
      while (P[1]=';') and (P[0]<>#0) do delete(P,1,1);
      if Chunk[ord(Chunk[0])]<>'\' then Chunk := Chunk + '\';
      Path := Chunk
   end; {Path}

   function Found(var F: text): boolean;                              {.CP14}
   {Takes file variable, tries to open it.  Closes file if opened. }
   {Reports success or failure in Found.                           }
   begin
      {$I-}
      reset(F);
      {$I+}
      if IOresult=0 then begin
         Found := True;
         close(F);
      end {if 0}
      else
         Found := False;
   end; {Found}

begin {FindFile}                                                      {.CP23}
   assign(F,FName);
   if Found(F) then
      GotIt := True
   else begin                                          {Strip all path specs}
      while (pos(':',FName)<>0) or (pos('\',FName)<>0) do
         delete(FName,1,1);
      Paths := EnvironLine('PATH');               {Get PATH from Environment}
      if Paths='NONE' then begin
         assign(F,FName);                     {if no PATH, try default drive}
         GotIt := Found(F)
      end {if NONE}
      else begin                                     {else search along PATH}
         repeat
            Try :=  Path(Paths);
            assign(F,Try + FName);
            GotIt := Found(F)
         until (Try='\') or GotIt;
         if GotIt then FName := Try + FName
      end {else found a PATH}
   end; {else not on default drive}
   FindFile := GotIt;
end; {FindFile}

function Escape: boolean;                                             {.CP15}
{  Empties the keyboard buffer & returns False if no trigger}
{  Does not wait for a keypress}

var
   C:              char;
   Temp:           boolean;
begin {Escape}
   Temp := False;
   while KeyPressed and not Temp do begin
      C := ReadKey;
      if C in Triggers then Temp := True
   end; {while}
   Escape := Temp;
end; {Escape}

procedure CloseCarefully;                                               {.CP9}
var
   Err: word;
begin
   {$I-}
   close(F);
   {$I+}
   Err := IOresult;
end; {CloseCarefully}

procedure Blank(Top,Bot: integer);                                     {.CP6}
var
   Row:              integer;
begin
   for Row := Top to Bot do CenterCRT('',Row,Bright,Inside)
end; {Blank}

procedure ByeBye;                                                     {.CP19}
begin
   CloseCarefully(Lst);
   Blank(8,9);
   Blank(18,19);
   if Enough
      then CenterCRT('That''s it, then.',18,Bright,0)
      else CenterCRT('Done.  ' + FileName + ' sent to ' + OutputDevice
                     + '.',10,Bright,Inside);
   CenterCRT('Signing Off.',19,Bright,0);
   if InABatch and Enough then begin
      CenterCRT('Can''t find ' + FileName,11,Bright,0);
      SetErrorLevel(1)      {BEWARE: RUN FROM TURBO, THIS QUITS TO DOS}
   end {if InABatch}
   else begin
      RestoreScreen;
      halt
   end
end; {ByeBye}

procedure GetOutOfHere;                                                {.CP5}
begin
   Enough := True;
   ByeBye
end; {GetOutOfHere}

procedure PXLRectangle;                                               {.CP11}
var
   I: integer;
begin
   WipeSlate(Scr,Bright);
   Rectangle(Scr,BoxT,BoxL,BoxB,BoxR,Dim,2,2);
   Center(Scr,' Pascal X-ref Lister (v. 1.42)',pred(BoxT),Dim,Inside);
   WriteIt(Scr,'R. N. Wisan  fecit  7/85-4/88',succ(BoxB),41,Dim);
   Center(Scr,'To stop, press <Esc>',BoxB -2,Bright,Inside);
   ToScrn(Scr);
end; {Rectangle}

procedure CantCont(FilNam,Comment: LineType);                         {.CP18}
var
   B:              byte;
begin
   Beep;
   CloseCarefully(Lst);
   Blank(10,18);
   CenterCRT('Can''t continue',10,Bright,0);
   if FilNam<>'' then CenterCRT('Error reading ' + FilNam,12,Bright,0);
   CenterCRT(Comment,13,Bright,0);
   Bop;
   if InABatch then
      SetErrorLevel(1)
   else begin
      RestoreScreen;
      Halt
   end
end; {CantCont}

procedure GetPrinterData;                                           {.CP18}
{If constant DataFiles is True, this procedure loads printer control }
{symbols from PXL.PRN.  If it's false, they're set here.             }

   procedure ReadPrn;  {from PXL.PRN}
   var
      F:              Fil;
      FilNam:         LineType;
   begin
      FilNam := 'PXL.PRN';
      GotPrnData := FindFile(FilNam);
      if GotPrnData then begin
         assign(F,FilNam);
         reset(F);
         for T := MrkB to FF do if not Eof(F) then read(F,Inst[T]);
         close(F)
      end {if no error}
   end; {ReadPrn}

   procedure IntPrn; {Set here for Epson FX-80}                       {.CP20}
   begin
      {Note: MrkB & MrkE are set for underline.  If you prefer some other}
      {way of marking the key words, change them here.                   }
      Inst[MrkB,0] := 3;
         Inst[MrkB,1] := 27;   Inst[MrkB,2] := 45;   Inst[MrkB,3] := 1;
      Inst[MrkE,0] := 3;
         Inst[MrkE,1] := 27;   Inst[MrkE,2] := 45;   Inst[MrkE,3] := 0;
      Inst[EliteB,0] := 2;
         Inst[EliteB,1] := 27; Inst[EliteB,2] := 77; Inst[EliteB,3] := $FF;
      Inst[EliteE,0] := 2;
         Inst[EliteE,1] := 27; Inst[EliteE,2] := 80; Inst[EliteE,3] := $FF;
      Inst[CondB,0] := 1;
         Inst[CondB,1] := 15;  Inst[CondB,2] := $FF; Inst[CondB,3] := $FF;
      Inst[CondE,0] := 1;
         Inst[CondE,1] := 18;  Inst[CondE,2] := $FF; Inst[CondE,3] := $FF;
      Inst[FF,0] := 1;
         Inst[FF,1] := 12;     Inst[FF,2] := $FF;    Inst[FF,3] := $FF;
      GotPrnData := True;
   end; {IntPrn}

begin {GetPrinterData}                                                {.CP10}
   if DataFiles then
      ReadPrn
   else
      IntPrn;
   if not GotPrnData then
      Inst[FF,1] := 66;                          {Default to Vanilla printer}
   if (Inst[FF,1] in [12,255])                               {Set Lines/Page}
      then MaxLin := 66 - BottomMargin
      else MaxLin := Inst[FF,1] - (BottomMargin)
end; {GetPrinterData}

function DefaultDrive: char; {Returns letter of Default Drive}        {.CP10}
var
   Regs:      Registers;
begin
   with Regs do begin
      AH := $19;
      MsDos(Regs);
      DefaultDrive := char(65 + AL)
   end {with Regs}
end; {DefaultDrive}

procedure FixUpFileName(Var FilNam: LineType);                        {.CP31}
const
   PathSigns: set of char = [':','\'];
var
   B,Len:       byte;
begin
   while (FilNam[1]=#32) and (FilNam[0]>#0) do         {Strip leading blanks}
      delete(FilNam,1,1);
   while FilNam[ord(FilNam[0])]=#32 do                {Strip trailing blanks}
      FilNam[0] := pred(FilNam[0]);
   for B := 1 to Length(FilNam) do                               {Capitalize}
      FilNam[B] := UpCase(FilNam[B]);
   B := ord(FilNam[0]);                           {count length of bare name}
   while (B>0) and not (FilNam[B] in PathSigns) do
      B := pred(B);
   Len := ord(FilNam[0]) - B;
   if pos(':',FilNam)=0 then          {if no drive letter, add Default Drive}
      FilNam := DefaultDrive + ':' + FilNam;
   if pos('.',FilNam)<>0 then begin                  {if has a period       }
      while (FilNam[0]>#0) and (FilNam[ord(FilNam[0])]='.') do begin
         FilNam[0] := pred(FilNam[0]);                 {delete terminal dots}
         Len := pred(Len)                              {adjust length count }
      end {while terminal dot}
   end {if has "."}
   else if Len>10 then begin                    {else if long, insert period}
      B := ord(FilNam[0]) - Len + 8;
      FilNam := concat(copy(FilNam,1,B),'.',copy(FilNam,succ(B),3))
   end {else no "." & over long}
   else
      FilNam := concat(FilNam,'.PAS')            {otherwise, default to .PAS}
end; {FixUpFileName}

function Shortened(FileName: LineType): Str20;
begin
   while (pos(':',FileName)<>0) or (pos('\',FileName)<>0) do
      delete(FileName,1,1);
   Shortened := FileName;
end; {Shortened}

procedure MakeBlnkLn; {private to PXLINIT}                             {.CP9}
var
   K: integer;
begin
   BlnkLn := '';
   for K := 1 to StdLineWidth do
      BlnkLn := BlnkLn + #32;
   Inside := pred(BoxR) - succ(BoxL);
end; {MakeBlnkLn}

begin {initialize PXLINIT}                                             {.CP5}
   OrigAtt := CurrentAttribute;
   GetScreen;
   MakeBlnkLn;
end.