Stars of Shareware: Programmierung/SOURCE.mdf/programm/msdos/pascal/pxl214a/pxlinit.pas

Pascal/Delphi Source File | 1993-02-14 | 45.6 KB | 1,242 lines

{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,655360}
{$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                                                                 {.CP17}
   TitleStr = ' PXL 2.14a Pascal X-Ref Lister';
   CreditStr = 'R. N. Wisan  fecit  7/85-10/90';
   PrnFileName = 'PXL.PRN';
   StdLineWidth   = 150;
   ScreenSize     = 2000;
   Triggers: set of char = [#27,#3];
   MaxResWords = 100;             {Enlarge if required}
   NoIncFiles = 8;
   InstLen    = 7;                {Maximum length of any printer instruction}
   BoxT =  5;
   BoxB = 21;
   BoxL = 10;
   BoxR = 70;
   EoFileSize      = 72; {Bt}
   PalaeoFileSize  = 28; {Bt}
   NeoFileSize     = 51; {Bt}


type                                                                  {.CP27}
   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;
   CMD      = string[128]; {For command line}
   Str40    = string[40];
   Str20    = string[20];
   ResWType = string[20]; {Must be large enough for longest reserved word}
   ResWPtrType = ^ResType;
   ResType     = Record
                    R: ResWType;
                    Next: ResWPtrType;
                 end;
   Str10    = string[10];
   Str9     = string[9];
   Str5     = string[5];
   Str4     = string[4];
   Str3     = string[3];
   str2     = string[2];

   (*                                                                {.CP18}
   Paleodata:
      Tpface   = (MrkB, MrkE, SmallB,SmallE,CondB,CondE,FF);
      ByteLine = array[0..3] of byte;
      Bytes    = array [MrkB..FF] of ByteLine;
   Eodata:
      Tpface     = (MrkB, MrkE, SmallB,SmallE,CondB,CondE,PreP,PostP,FF);
      ByteLine   = array[0..7] of byte;
   *)
   Tpface          = (MrkB, MrkE, SetLg,SetSm,PreP,PostP,FF,LW,SW);
   ByteLine        = array[0..InstLen] of byte;
   InsType         = string[InstLen];
   PrnDataType     = record
                       Tp:  array[MrkB..PostP] of ByteLine;
                       Bt:  array[FF..SW] of byte;
                     end; {PrnDataType}    {58 Bt}
   NeoFileType     = File of PrnDataType;
   FoundType       = (Palaeo,Eo,Neo,Wrong,NoFile);

const
   ByteSet: set of TpFace = [FF..SW];

var                                                                   {.CP23}
   CRTube:    ScrPtrType;  {Set to point at real screen buffer}
   CRTAddr:   array[1..2] of word absolute CRTube;
   Monitor:   MonitorType;
   OrigAtt:   byte;
   BlnkLn:    string;
   Scr:                ScrType;
   C:                  char;
   MaxResLen,
   Inside,
   BottomMargin,
   MaxLin,
   NormalColor,
   FrameColor,
   Background,
   Bright,Dim:         byte;
   F,Lst:              text;
   IFil:               array[1..NoIncFiles] of text;
   IFileName:          array[1..NoIncFiles] of string;
   IFN:                1..NoIncFiles;
   QuitStrg,
   PathSign,
   FileName:           string;
   Opening,Closing:    InsType;                                       {.CP26}
   PrintDate,
   FileDate:           Str20;
   PrintTime,
   FileTime:           Str10;
   UserID:             string[25];
   Number:             string[16];
   Line:               string;
   Day,I,LineNumber,
     PageLineNumber,
     Page,Year,NRes:  integer;
   ScrSeg:             word;
   GotPrnData,Plain,
     MarkWCaps,
     MarkWCR,
     Vanilla,Turbo3,
     PrePSent,
     Mrk,XRef,
     XRefOnly,Enough,
     NumberLines,
     InABatch,FFeed,
     DataFiles:        boolean;
   Inst:               PrnDataType;
   T:                  TpFace;
   Istring:            array[MrkB..PostP] of InsType absolute Inst;
   Rsv:                array['A'..'Z'] of ResWPtrType;
   OutputDevice:       Str40;
   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: string; R,C,Color: byte);
procedure WriteCRT(Str: string; Row,Col,Att: byte);
procedure CenterCRT(S: string; Row,Attrib,Width: byte);
procedure Center(var Scr: ScrType; Str: string; 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 Intensified(A: byte): byte;
function Dimmed(A: byte): byte;
function BlackBackground(A: byte): boolean;
function BlackForeground(A: byte): boolean;
function BackgroundOf(A: byte): byte;
function ForegroundOf(A: byte): byte;
function CombinedAttributeOf(F,B: byte): byte;

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

function StrgI(B,L: Integer): Str9;
function Strip(L: string; NoNo: CharSet): string;
(* function InCapitals(L: string): string; *)
function InCapitals(S: string): string; { Assembler;}

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

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

function EnvironLine(LineStart: string): string;                      {.CP3}
   {Searches DOS environment for line beginning with LineStart}
   {If found, returned in EnvironLine.  If not returns "NONE"}
function FindFile(var FName: string): 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);                                 {.CP4}
{Closes text file whether open or not.  Closing open file in TP3 was harm-}
{less, but TP4 birks at closing files which aren't open.  Unfortunately,  }
{you need one of these for each file type.  This is for text files.       }

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: string);
procedure GetPrinterData;                                              {.CP3}
  { If constant DataFiles is True, this procedure loads printer control }
  { symbols from PrnFileName.  If it's false, they're set here.         }
function DefaultDrive: char; {Returns letter of Default Drive}
procedure FixUpFileName(Var FilNam: string);
function Shortened(FileName: string): Str20;

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

Implementation

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

procedure Beep;                                                        {.CP4}
{Starts the sound that BOP finishes}
begin
   sound(456);
end; {Beep}

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

procedure ToScrn(var S: ScrType);                                     {.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(var S: ScrType);                                   {.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(Segm,Offst,Num,Wd: word);                            {.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(Segm,Offst,Num: integer; Bt: byte);                 {.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(var From,Target; Num: word);                       {.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(var S: ScrType; R1,C1,R2,C2,Att,Vert,Hor: byte);  {.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(var Scr: ScrType; Str: string; R,C,Color: byte);   {.CP6}
{R is row; C is column in which to start.}
begin
   FillWd(Seg(Scr[R,C]),Ofs(Scr[R,C]),length(Str),succ(Color shl 8));
   SkipMove(Str[1],Scr[R,C],length(Str));
end; {WriteIt}

procedure WriteCRT(Str: string; Row,Col,Att: byte);                  {.CP5}
 { 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(S: string; Row,Attrib,Width: byte);              {.CP8}
begin
   if Width >0 then begin
      BlnkLn[0] := char(Width);
      WriteCRT(BlnkLn,Row,41-(length(BlnkLn) div 2),Attrib);
   end; {if Width}
   WriteCRT(S,Row,41-(length(S) div 2),Attrib)
end;

procedure Center(var Scr: ScrType;                                    {.CP15}
                     Str: string;
                     Line,Color,Width: byte);
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 - (length(Str) 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 Intensified;                                                  {.CP4}
begin
   Intensified := A or 8;
end; {Intensified}

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

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 CombinedAttributeOf;                                          {.CP5}
{Intensity follows F(oreground); ignores blinking.}
begin
   CombinedAttributeOf := ((B and 7) shl 4) or (F and 15)
end; {CombinedAttributeOf}

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

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

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

function Strip(L: string; NoNo: CharSet): string;                  {.CP7}
{remove leading & trailing junk (list comes in  NoNo)}
begin {Strip}
   while (length(L)>0) and (L[1] in NoNo) do delete(L,1,1);
   while L[length(L)] in NoNo do dec(L[0]);
   Strip := L
end; {Strip}
(*
function InCapitals(L: string): string;                            {.CP7}
var   {old form}
   K:              byte;
begin {InCapitals}
   for K := 1 to length(L) do L[K] := UpCase(L[K]);
   InCapitals := L
end; {InCapitals}
*)
function InCapitals(S: string): string; Assembler;                {.CP25}
{PC Techniques HAX 144 v3n6 definitely faster than old form }
{oddly, adding Hax 147 doesn't make it faster}
ASM
   push ds           {Preserve data segment}
   lds  si,S         {Load DS:SI w S's address}
   les  di,@result   {Load ES:DI w function result's address}
   cld               {SI will be incremented}
   lodsb             {Get S[0]; put it in AL}
   stosb             {Store AL in ES:01}
   cmp al,2          {Check for zero length  --This is what HAX 144 missed}
   jl  @out          {actually, minimum parameter is 2 char (1 for the blank}
   xor ch,ch         {Zero CH}
   mov cl,al         {Length of S into counter CL}
@more:
   lodsb             {next char -> AL}
   cmp al,'a'        {is it 'a'?}
   jb  @no           {if below, skip out}
   cmp al,'z'        {is it 'z'?}
   ja  @no           {if above, skip out}
   sub al,20h        {subtract 32 = lower case}
@no:
   stosb             {store AL in ES:DI}
@loopy:
   loop @more        {Go back for next until CX=0}
@out:
   pop  ds           {Restore data segment}
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:         string;
   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: string, DOS.Registers}
var
   Data: array[1..64] of char;
   Regs: DOS.Registers;
   Bt:  byte;
   S:    string;

   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:               string;
   EnvAdd:          word;
   B:               word;
   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);
         if S='PATH' then
            B := B;
      end; {while}
      if pos(LineStart,S)=1 then begin
         delete(S,1,length(LineStart));
         while S[1] in [' ','='] do delete(S,1,1);
         EnvironLine := S;
         LineFound := True
      end; {if PATH}
      B := succ(B)
   until (length(S)=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:       string;
   F:         text;   {File type doesn't matter.  File only reset, not read.}
   GotIt:     boolean;

   function Path(var P: string): string;                          {.CP15}
   {Takes DOS PATH line and peels one path specifier from it.  }
   {Returns specifier in Path, bobtailed DOS PATH line in P.   }
   var
      Chunk:     string;
   begin
      Chunk := '';
      while (P[1]<>';') and (length(P)<>0) do begin
         Chunk := Chunk + P[1];
         delete(P,1,1)
      end; {while not ";"}
      while (P[1]=';') and (length(P)<>0) do delete(P,1,1);
      if Chunk[length(Chunk)]<>'\' 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}
{Closes text file whether open or not.  Closing open file in TP3 was harm-}
{less, but TP4 birks at closing files which aren't open.  Unfortunately,  }
{you need one of these for each file type.  This is for text files.       }
var
   Err: word;
begin
   {$I-}
   close(F);
   {$I+}
   Err := IOresult;  {draws the teeth of 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
   if PrePSent then write(Lst,QuitStrg);
   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 TP 3, 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,TitleStr,pred(BoxT),Dim,Inside);
   WriteIt(Scr,CreditStr,succ(BoxB),41,Dim);
   Center(Scr,'To stop, press <Esc>',BoxB -2,Bright,Inside);
   ToScrn(Scr);
end; {Rectangle}

procedure CantCont(FilNam,Comment: string);                         {.CP19}
var
   B:              byte;
begin
   Beep;
   if PrePSent then write(Lst,QuitStrg);
   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;                                             {.CP10}
{If constant DataFiles is True, this procedure loads printer control }
{symbols from PrnFileName.  If it's false, they're set here.         }
type
   OldByteLine   = array[0..4] of byte;
   OldFileType   = File of OldByteLine;
var
   Fb:      file of byte;
   FName:   string;
   T:       TpFace;

   procedure ReadPrnFile;                                              {.CP7}
   var
      Fb: file of byte;
      F:  NeoFileType;
      I:  integer;
      B:  byte;
      Found: FoundType;

      function WhatWeGot: FoundType;                                  {.CP15}
      var
         Len: longint;
      begin
         assign(Fb,FName);
         reset(Fb);
         Len := FileSize(Fb);
         case Len of
            PalaeoFileSize: WhatWeGot := Palaeo;
            EoFileSize:     WhatWeGot := Eo;
            NeoFileSize:    WhatWeGot := Neo;
            else            WhatWeGot := Wrong;
         end; {Case}
         close(Fb);
      end; {WhatWeGot}

      procedure ReadInOldFile;                                        {.CP20}
      Type
         OldTpface = (OldMrkB,OldMrkE,OldSmallB,OldSmallE,
                      OldCondB,OldCondE,OldPreP,OldPostP,OldFF);
         OldBLine  = array[0..7] of byte;
      var
         Len,B: byte;
         T: OldTpface;
         OInst: array[OldMrkB..OldFF] of OldBLine;
         EliteIsCond: boolean;
      begin
         if Found=Eo
            then Len := 7         {Eo files have 7-byte strings}
            else Len := 3;        {Palaeo files have 3-byte strings}
         for T := OldMrkB to OldFF do begin  {carefully empty Inst}
            OInst[T,0] := 0;
            fillchar(OInst[T,1],Len,$FF);
         end; {for T}
         assign(Fb,FName);
         reset(Fb);
         for T := OldMrkB to OldCondE do                              {.CP10}
            for B := 0 to Len do
               read(Fb,OInst[T,B]);
         if Found=Eo then                {Eo files have 2 extra instructions}
            for T := OldPreP to OldPostP do
               for B := 0 to Len do
                  read(Fb,OInst[T,B]);
(*         read(Fb,OInst[OldFF,0],OInst[OldFF,1]); *)
         read(Fb,OInst[OldFF,0],OInst[OldFF,1]); {get just the first 2 bytes}
         close(Fb);
         EliteIsCond := True;                                         {.CP22}
         for B := 0 to Len do
            if OInst[OldSmallB,B]<>OInst[OldCondB,B] then
               EliteIsCond := False;
         if OInst[OldFF,0]=1 then Inst.Bt[FF] := OInst[OldFF,1];
         Move(OInst[OldMrkB],Inst.Tp[MrkB],succ(OInst[OldMrkB,0]));
         Move(OInst[OldMrkE],Inst.Tp[MrkE],succ(OInst[OldMrkE,0]));
         if Found=Eo then begin
            Move(OInst[OldPreP], Inst.Tp[PreP], succ(OInst[OldPreP,0]));
            Move(OInst[OldPostP],Inst.Tp[PostP],succ(OInst[OldPostP,0]));
         end; {if Eo}
         if OInst[OldSmallB,0]<>0 then begin
            Move(OInst[OldSmallB],Inst.Tp[SetSm],succ(OInst[OldSmallB,0]));
            Move(OInst[OldSmallE],Inst.Tp[SetLg],succ(OInst[OldSmallE,0]));
         end {if OldSmall}
         else if OInst[OldCondB,0]<>0 then begin
            Move(OInst[OldCondB],Inst.Tp[SetSm],succ(OInst[OldCondB,0]));
            Move(OInst[OldCondE],Inst.Tp[SetLg],succ(OInst[OldCondE,0]));
            Inst.Bt[SW] := 131;
         end; {else if OldCond}
         if EliteIsCond then Inst.Bt[SW] := 131;
      end; {ReadInOldFile}

   begin  {ReadPrnFile}                                               {.CP25}
      FName := PrnFileName;
      if FindFile(Fname) then begin
         GotPrnData := TRUE;
         Found := WhatWeGot;
         if Found=Neo then begin
            assign(F,FName);
            Reset(F);
            read(F,Inst);
            close(F);
         end {else neo style}
         else begin
            Inst.Bt[LW] := 79; {default}
            Inst.Bt[SW] := 95; {assumption}
            if Found in [Eo,Palaeo]
               then ReadInOldFile
               else GotPrnData := False; {Found=Wrong --file is ng}
         end {if old file}
      end {if found file}
      else begin
         Found := NoFile;
         GotPrnData := FALSE;
         GotoXY(1,23)
      end; {else}
   end; {ReadPrnFile}

   procedure IntPrn; {Set here for Epson FX-80}                        {.CP4}
   begin
      {Note: MrkB & MrkE are set for underline.  If you prefer some other}
      {way of marking the key words, change them here. If you put nothing}
      {for both of them (set Tp[MrkB,0] := 0 and Tp[MrkE,0] := 0) the key}
      {words will be marked by printing them in CAPITALS.                }
      with Inst do begin
         Tp[MrkB,0] := 3;                                              {.CP4}
            Tp[MrkB,1] := 27;    Tp[MrkB,2] := 45;    Tp[MrkB,3] := 1;
            Tp[MrkB,4] := $FF;   Tp[MrkB,5] := $FF;   Tp[MrkB,6] := $FF;
            Tp[MrkB,7] := $FF;
         Tp[MrkE,0] := 3;                                              {.CP4}
            Tp[MrkE,1] := 27;    Tp[MrkE,2] := 45;    Tp[MrkE,3] := 0;
            Tp[MrkE,4] := $FF;   Tp[MrkE,5] := $FF;   Tp[MrkB,6] := $FF;
            Tp[MrkE,7] := $FF;
         Tp[SetSm,0] := 2; {Elite}                                     {.CP4}
            Tp[SetSm,1] := 27;  Tp[SetSm,2] := 77;  Tp[SetSm,3] := $FF;
            Tp[SetSm,4] := $FF; Tp[SetSm,5] := $FF; Tp[SetSm,6] := $FF;
            Tp[SetSm,7] := $FF;
         Tp[SetLg,0] := 2; {Pica}                                      {.CP4}
            Tp[SetLg,1] := 27;  Tp[SetLg,2] := 80;  Tp[SetLg,3] := $FF;
            Tp[SetLg,4] := $FF; Tp[SetLg,5] := $FF; Tp[SetLg,6] := $FF;
            Tp[SetLg,7] := $FF;
         Tp[PreP,0] := 0;                                              {.CP4}
            Tp[PreP,1] := $FF;   Tp[PreP,2] := $FF;   Tp[PreP,3] := $FF;
            Tp[PreP,4] := $FF;   Tp[PreP,5] := $FF;   Tp[PreP,6] := $FF;
            Tp[PreP,7] := $FF;
         Tp[PostP,0] := 0;                                            {.CP10}
            Tp[PostP,1] := $FF;  Tp[PostP,2] := $FF;  Tp[PostP,3] := $FF;
            Tp[PostP,4] := $FF;  Tp[PostP,5] := $FF;  Tp[PostP,6] := $FF;
            Tp[PostP,7] := $FF;
         Bt[FF] := 12;   {form-feed}
         Bt[LW] := 79;   {pica length}
         Bt[SW] := 95;   {elite length}
      end; {with Inst}
      GotPrnData := True;
   end; {IntPrn}

begin {GetPrinterData}                                                {.CP16}
   if DataFiles then
      ReadPrnFile
   else
      IntPrn;
   if not GotPrnData then
      with Inst do begin
         Bt[FF] := 66;            {Default to Vanilla printer @ 66 lines/page}
         Bt[LW] := 79;            {pica width}
         Bt[SW] := 79;            {elite width -can't assume a small font}
         for T := MrkB to PostP do Inst.Tp[T,0] := 0  {Blank other instrucs}
      end; {with Inst}
   MarkWCR := (Inst.Tp[MrkB,0]=0) and (Inst.Tp[MrkE,0]=0);
   if Inst.Bt[FF]=12                       {Set Lines/Page}
      then MaxLin := 66 - BottomMargin            {if using Form-Feed}
      else MaxLin := Inst.Bt[FF] - (BottomMargin) {else paging w so many LFs}
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: string);                        {.CP31}
const
   PathSigns: set of char = [':','\'];
var
   B,Len:       byte;
begin
   while (FilNam[1]=#32) and (length(FilNam)>0) do     {Strip leading blanks}
      delete(FilNam,1,1);
   while FilNam[length(FilNam)]=#32 do                {Strip trailing blanks}
      dec(FilNam[0]);
   for B := 1 to Length(FilNam) do                               {Capitalize}
      FilNam[B] := UpCase(FilNam[B]);
   B := length(FilNam);                           {count length of bare name}
   while (B>0) and not (FilNam[B] in PathSigns) do
      dec(B);
   Len := length(FilNam) - 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 (length(FilNam)>0) and (FilNam[length(FilNam)]='.') do begin
         dec(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 := length(FilNam) - 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: string): Str20;                         {.CP6}
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;
   PrePSent := False;
   QuitStrg := '';
end.