ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/PPP.ZIP/PPP.PAS

Pascal/Delphi Source File | 1991-03-29 | 28.4 KB | 833 lines

(* PPP - Author: Martin Bless 890224                           *)
(* Pretty Print Pascal. Compiled with Turbo-Pascal 5.0         *)

{$UNDEF debug}          (* may be changed to DEFINE            *)
{$UNDEF sort}           (* use DEFINE for nonordered keywords  *)
{$A+,B-,D+,E+,F-,I+,L-,N-,O-,R+,S+,V-}
{$M 16384,0,655360}

PROGRAM PPP;

USES
  Crt, Dos;

CONST
  tabLen        =   8;                 (* # of blanks for tabs *)
  nKeyWords     = 245;                 (* number of keywords   *)
  keyWordLength =  25;                 (* length of keywords   *)
  idSet    = ['A'..'Z', 'a'..'z',      (* legal chars for      *)
              '0'..'9','_'];           (*   identifier         *)
  printSet = [#3..#6, #21, #32..#126,  (* printable chars of   *)
              #128..#254];             (*   NEC-P6             *)

TYPE
  DestType       = (console, printer, necP6, datei, norton);
  KeyWordType    = STRING[ keyWordLength];
  KeyWordsType   = ARRAY[ 1..nKeyWords] OF KeyWordType;
  ColorTableType = ARRAY[ 0..7] OF BYTE;

CONST
  colorTable: ColorTableType =(
    $07,   (* light grey:=hellgrau *)     (* normal text       *)
    $07,   (* hellgrau *)                 (* comments          *)
    $0F,   (* weia     *)                 (* keyword class '1' *)
    $07,   (* hellgrau *)                 (* keyword class '2' *)
    $07,   (* hellgrau *)                 (* keyword calss '3' *)
    $07,   (* hellgrau *)                 (* keyword class '4' *)
    $07,   (* hellgrau *)                 (* keyword class '5' *)
    $07    (* hellgrau *)                 (* keyword class '6' *)
    );

(* IMPORTANT: keywords in alphabetic order, CASE INDEPENDENT!  *)
(*            MUST have trailing blank and class number        *)
  key:KeyWordsType = (
'Abs 2', 'ABSOLUTE 1', 'Addr 2', 'AND 1', 'Append 2', 'Arc 2',
'ArcTan 2', 'ARRAY 1', 'Assign 2', 'AssignCrt 2', 'Bar 2',
'Bar3D 2', 'BEGIN 1', 'BlockRead 2', 'BlockWrite 2', 'BOOLEAN 1',
'BYTE 1', 'CASE 1', 'CHAR 1', 'ChDir 2', 'Chr 2', 'Circle 2',
'ClearDevice 2', 'ClearViewPort 2', 'Close 2', 'CloseGraph 2',
'ClrEol 2', 'ClrScr 2', 'Concat 2', 'CONST 1', 'Copy 2', 'Cos 2',
'CSeg 2', 'DEC 1', 'Delay 2', 'Delete 2', 'DelLine 2',
'DetectGraph 2', 'DiskFree 2', 'DiskSize 2', 'Dispose 2',
'DIV 1', 'DO 1', 'DosExitCode 2', 'DOWNTO 1', 'DrawPoly 2',
'DSeg 2', 'Ellipse 2', 'ELSE 1', 'END 1', 'Eof 2', 'Eoln 2',
'Erase 2', 'Exec 2', 'EXIT 1', 'Exp 2', 'EXTERNAL 1', 'FALSE 1',
'FILE 1', 'FilePos 2', 'FileSize 2', 'FillChar 2', 'FillPoly 2',
'FindFirst 2', 'FindNext 2', 'FloodFill 2', 'Flush 2', 'FOR 1',
'FORWARD 1', 'Frac 2', 'FreeMem 2', 'FUNCTION 1',
'GetArcCoords 2', 'GetAspectRatio 2', 'GetBkColor 2',
'GetColor 2', 'GetDate 2', 'GetDir 2', 'GetFAttr 2',
'GetFillSettings 2', 'GetFTime 2', 'GetGraphMode 2',
'GetImage 2', 'GetIntVec 2', 'GetLineSettings 2', 'GetMaxX 2',
'GetMaxY 2', 'GetMem 2', 'GetPalette 2', 'GetPixel 2',
'GetTextSettings 2', 'GetTime 2', 'GetViewSettings 2', 'GetX 2',
'GetY 2', 'GOTO 1', 'GotoXY 2', 'GraphErrorMsg 2',
'GraphResult 2', 'HALT 2', 'Hi 2', 'HighVideo 2', 'IF 1',
'ImageSize 2', 'IMPLEMENTATION 1', 'IN 1', 'INC 1',
'InitGraph 2', 'INLINE 1', 'Insert 2', 'InsLine 2', 'Int 2',
'INTEGER 1', 'INTERFACE 1', 'INTERRUPT 1', 'Intr 2',
'IOResult 2', 'Keep 2', 'KeyPressed 2', 'LABEL 1', 'Length 2',
'Line 2', 'LineRel 2', 'LineTo 2', 'Ln 2', 'Lo 2', 'LongInt 1',
'LowVideo 2', 'Mark 2', 'MaxAvail 2', 'MemAvail 2', 'MkDir 2',
'MOD 1', 'Move 2', 'MoveRel 2', 'MoveTo 2', 'MsDos 2', 'New 2',
'NIL 1', 'NormVideo 2', 'NoSound 2', 'NOT 1', 'Odd 2', 'OF 1',
'Ofs 2', 'OR 1', 'Ord 2', 'OutText 2', 'OutTextXY 2', 'PACKED 1',
'PackTime 2', 'ParamCount 2', 'ParamStr 2', 'Pi 2', 'PieSlice 2',
'POINTER 1', 'Pos 2', 'Pred 2', 'PROCEDURE 1', 'PROGRAM 1',
'Ptr 2', 'PutImage 2', 'PutPixel 2', 'Random 2', 'Randomize 2',
'Read 2', 'ReadKey 2', 'ReadLn 2', 'RECORD 1', 'Rectangle 2',
'Release 2', 'Rename 2', 'REPEAT 1', 'Reset 2', 'RestoreCrt 2',
'RestoreCrtMode 2', 'Rewrite 2', 'RmDir 2', 'Round 2', 'Seek 2',
'SeekEof 2', 'SeekEoln 2', 'Seg 2', 'SET 1', 'SetActivePage 2',
'SetAllPalette 2', 'SetBkColor 2', 'SetColor 2', 'SetDate 2',
'SetFAttr 2', 'SetFillPattern 2', 'SetFillStyle 2', 'SetFTime 2',
'SetGraphMode 2', 'SetIntVec 2', 'SetLineStyle 2',
'SetPalette 2', 'SetTextBuf 2', 'SetTextJustify 2',
'SetTextStyle 2', 'SetTime 2', 'SetViewPort 2',
'SetVisualPage 2', 'SHL 1', 'ShortInt 1', 'SHR 1', 'Sin 2',
'SizeOf 2', 'Sound 2', 'SPtr 2', 'Sqr 2', 'Sqrt 2', 'SSeg 2',
'Str 2', 'STRING 1', 'Succ 2', 'Swap 2', 'TEXT 1',
'TextBackground 2', 'TextColor 2', 'TextHeight 2', 'TextMode 2',
'TextWidth 2', 'THEN 1', 'TO 1', 'TRUE 1', 'Trunc 2',
'Truncate 2', 'TYPE 1', 'UNIT 1', 'UnpackTime 2', 'UNTIL 1',
'UpCase 2', 'USES 1', 'Val 2', 'VAR 1', 'WhereX 2', 'WhereY 2',
'WHILE 1', 'Window 2', 'WITH 1', 'WORD 1', 'Write 2',
'WriteLn 2', 'XOR 1'
);

VAR (* general global *)
  ch:       CHAR;               (* current char of source file *)
  lk:       CHAR;               (* last key                    *)
  goFlag:   CHAR;               (* #32 = ' ' = go!             *)

VAR (* keyword finding *)
  keyIndex: WORD;               (* index of keyword found      *)
  idPos:    WORD;               (* position in id string       *)
  id:       KeyWordType;        (* identifier buffer           *)

VAR (* program flow *)
  convert: BOOLEAN;             (* convert KeyWords?           *)

VAR  (* printing *)
  dest:      DestType;       (* output destiniation            *)
  lpp:       WORD;           (* lines per page                 *)
  cpl:       WORD;           (* columns per line               *)
  colCnt:    WORD;           (* current column                 *)
  lineCnt:   WORD;           (* current line                   *)
  pageCnt:   WORD;           (* current page                   *)
  lMargin:   WORD;           (* left margin in # of blanks     *)
  inComment: BOOLEAN;        (* true if comment printing is on *)
  inKeyWord: BOOLEAN;        (* true if keyword printing is on *)
  color:     WORD;           (* index to colorTable            *)

VAR (* for Norton Guides *)
  totalBytes: WORD;              (* count all bytes output     *)
  shortCnt:   WORD;              (* count # of short entries   *)

VAR  (* files *)
  f1File:         Text;                     (* input file      *)
  f2File:         Text;                     (* output file     *)
  f1Name, f2Name: STRING[ 80];              (* fileNames       *)
  f1Open, f2Open: BOOLEAN;                  (* open indicators *)

FUNCTION LastKey:CHAR;     (* get last key pressed, #0 if none *)
VAR
  rk: CHAR;
BEGIN
  rk := #0;
  IF KeyPressed THEN BEGIN;
    rk := ReadKey;
    IF rk = #0 THEN BEGIN                  (* eat function key *)
       rk := ReadKey;
       rk := #0;
    END;
  END;
  LastKey := rk;
END;

FUNCTION WaitKey: CHAR;                   (* wait for keypress *)
BEGIN
  WHILE NOT KeyPressed DO;                (* loop              *)
  WaitKey := LastKey;
END;

FUNCTION UpStr( s:STRING):STRING;         (* convert string to *)
VAR                                       (* upper case        *)
  c: WORD;
BEGIN
  FOR c:= 1 TO Length( s) DO BEGIN
    UpStr[c] := UpCase( s[c]);
  END;
  UpStr[0] := s[0];                      (* set correct length *)
END;


{$IFDEF sort}
PROCEDURE SortKeyWords;                   (* case independent! *)
VAR
  x, y: KeyWordType;

PROCEDURE QSort( l, r:WORD);           (* Quicksort (rekursiv) *)
VAR
  i, j: WORD;
BEGIN
  i := l;
  j := r;
  x := UpStr( key[ (l+r) DIV 2]);         (* case independent! *)
  REPEAT
    WHILE UpStr( key[ i]) < x DO INC(i);  (* case independent! *)
    WHILE x < UpStr( key[ j]) DO DEC(j);  (* case independent! *)
    IF i <= j THEN BEGIN
      y       := key[ i];
      key[ i] := key[ j];
      key[ j] := y;
      INC( i);
      DEC( j);
    END;
  UNTIL i > j;
  IF l < j THEN QSort( l, j);
  IF i < r THEN QSort( i, r);
END; (* QSort *)

BEGIN
  IF nKeyWords > 0 THEN QSort( 1, nKeyWords);
END; (* SortKeyWords *)
{$ENDIF}

{$IFDEF debug}
PROCEDURE ShowKeyWords;
VAR
  c: WORD;
BEGIN
  FOR c:= 1 TO nKeyWords DO BEGIN
    WriteLn( c:5, '':5, key[c]);
  END;
END;
{$ENDIF}

FUNCTION Space( n:BYTE):STRING;   (* return string of n spaces *)
VAR
  c: WORD;
BEGIN
  Space[0] := Chr(n);
  FOR c := 1 TO n DO BEGIN
    Space[c] := ' ';
  END;
END;

PROCEDURE SendCh( c:CHAR);    (* all output done here charwise *)
BEGIN                         (* IOResult may be checked       *)
  (*$I-*)
  Write( f2File, c);          (* !!!!! OUTPUT TO f2File !!!!!  *)
  (*$I+*)
  IF IOResult <> 0 THEN BEGIN      (* stop program immediately *)
    IF f1Open THEN Close( f1File); (* try a clean exit         *)
    IF f2Open THEN Close( f2File); (*                          *)
    WriteLn('PPP - Error on output to '#39+
             f2Name+#39);          (* let user know            *)
    Halt( 1);                      (* abort with errorlevel 1  *)
  END;
  INC( totalBytes);           (* count bytes for norton guides *)
END;

PROCEDURE SendStr( s:STRING);                   (* send string *)
VAR
  c: WORD;
BEGIN
  FOR c:= 1 TO Length( s) DO BEGIN
    SendCh( s[c]);
  END;
END;

PROCEDURE AbortProgram( msg:STRING);      (* no msg = no error *)
BEGIN
  IF f2Open AND (msg<>'') AND
     (colCnt <> 1) THEN
  BEGIN
    SendStr( #13#10);                     (* try to close line *)
  END;
  IF f1Open THEN Close( f1File);
  IF f2Open THEN Close( f2File);
  IF msg[0] > #0 THEN BEGIN
    WriteLn;
    WriteLn( msg);
    Halt( 1);                       (* abort with errorlevel 1 *)
  END;
  Halt( 0);              (* abort with errorlevel 0 (no error) *)
END;

FUNCTION DateStr: STRING;                  (* returns TT.MM.JJ *)
VAR
  yy, mm, dd, dow: WORD;
  ys, ms, ds:      STRING[4];
BEGIN
  GetDate ( yy, mm, dd, dow);
  Str( dd:2, ds);   IF dd<10 THEN ds[1] := '0';
  Str( mm:2, ms);   IF mm<10 THEN ms[1] := '0';
  Str( yy:4, ys);
  DateStr := ds+'.'+ms+'.'+Copy(ys,3,2);
END;

FUNCTION TimeStr: STRING;                  (* returns HH:MM:SS *)
VAR
  hh, mm, sec, sec100: WORD;
  hs, ms, ss:          STRING[4];
BEGIN
  GetTime ( hh, mm, sec, sec100);
  Str( hh:2, hs);   IF  hh<10 THEN hs[1] := '0';
  Str( mm:2, ms);   IF  mm<10 THEN ms[1] := '0';
  Str( sec:2, ss);  IF sec<10 THEN ss[1] := '0';
  TimeStr := hs+':'+ms+':'+ss;
END;

PROCEDURE KeyWordOn;                    (* a keyword follows   *)
BEGIN
  inKeyWord := TRUE;
  CASE dest OF
    console: TextAttr := colorTable[ color];
    necP6  : IF color = 2 THEN BEGIN
               SendStr( #27'E');        (* Shadowed font ON *)
             END;
    printer: ;
    datei  : ;
    norton : IF color = 2 THEN BEGIN
               SendStr('^B');           (* highlighted ON      *)
             END;
  END;
END;

PROCEDURE KeyWordOff;                   (* end of keyword      *)
BEGIN
  inKeyWord := FALSE;
  CASE dest OF
    console: TextAttr := colorTable[ 0];
    necP6  : IF color = 2 THEN BEGIN
               SendStr( #27'F');        (* Shadowed font OFF *)
             END;
    printer: ;
    datei  : ;
    norton : IF color = 2 THEN BEGIN
               SendStr('^N');           (* back to normal      *)
             END;
  END;
END;

PROCEDURE CommentOn;                    (* a comment follows   *)
BEGIN
  inComment := TRUE;
  CASE dest OF
    necP6:    SendStr(#27'4');                (* italics ON    *)
    console:  TextAttr := colorTable[1];      (* comment color *)
    printer: ;
    datei  : ;
  END;
END;

PROCEDURE CommentOff;                        (* end of comment *)
BEGIN
  inComment := FALSE;
  CASE dest OF
    necP6:    SendStr(#27'5');                 (* italics OFF  *)
    Console:  TextAttr := colorTable[0];       (* normal color *)
    printer: ;
    datei  : ;
  END;
END;

PROCEDURE PrintTitle;     (* only when printer format selected *)
VAR
  c, tabPos:   WORD;
  s:           STRING[50];
  myInComment: BOOLEAN;
  myInKeyWord: BOOLEAN;
BEGIN
  IF NOT (dest IN
     [printer, necP6]) THEN
  BEGIN
    EXIT;                                (* if not for printer *)
  END;
  myInComment := inComment;    (* print headline always normal *)
  myInKeyWord := inKeyWord;
  IF inComment THEN CommentOff;
  IF inKeyWord THEN KeyWordOff;
  SendCh( #13);             (* print head to beginning of line *)
  FOR c:= 1 TO 2 DO BEGIN
    SendCh( #10);                               (* empty lines *)
    INC( lineCnt);
  END;
  SendStr( Space( lMargin));                    (* left margin *)
  SendStr( DateStr+'  '+TimeStr);
  Str( pageCnt:3, s);
  SendStr( '  Seite'+s);                        (* page number *)
  colCnt := lMargin+1+8+2+8+7+3;        (* adjust column count *)
  SendStr( Space( cpl - colCnt - Length( f1Name)+1));
  SendStr( f1Name );        (* print file name right justified *)
  SendCh( #13);                   (* back to beginning of line *)
  colCnt := 1;
  FOR c:= 1 TO 3 DO BEGIN
    SendCh( #10);                             (* 2 empty lines *)
    INC( lineCnt);
  END;
  IF myInComment THEN CommentOn;      (* restore printing mode *)
  IF myInKeyWord THEN KeyWordOn;
END;

FUNCTION ShortString:String;             (* for norton guides  *)
VAR                                      (* insert: !SHORT ... *)
  s: STRING[10];
BEGIN
  INC( shortCnt);
  Str( shortCnt, s);
  ShortString := '!SHORT '+f1Name+' ...'+s+#13+#10;
END;

PROCEDURE LeftMargin;           (* send blanks for left margin *)
VAR
  c: WORD;
BEGIN
  FOR c := 1 TO lMargin DO BEGIN
    SendCh( ' ');
    INC( colCnt);                             (* count columns *)
  END;
END;

PROCEDURE NextPage;                      (* next printing page *)
BEGIN
  INC( pageCnt);                                (* count pages *)
  colCnt  := 1;
  lineCnt := 1;
  IF NOT (dest IN [console, printer, necP6]) THEN BEGIN
    EXIT;        (* nothing inserted, if destination is a file *)
  END;
  IF dest = console THEN BEGIN
    IF goFlag <> ' ' THEN BEGIN
      Write( f2File, Space( 60), '(Space-) Bar ...');
      lk := WaitKey;
      IF lk=#27 THEN BEGIN               (* ESCape key pressed *)
        AbortProgram( '');               (* aborted by user    *)
      END;
      IF lk <> #0 THEN BEGIN
        goFlag := lk;                    (* save last key      *)
      END;
      SendCh( #13);
      ClrEol;
    END;
    EXIT;
  END;
  SendCh( #13);                    (* back to column 1         *)
  SendCh( #12);                    (* send FORM FEED character *)
END;

PROCEDURE NextLine;                (* next line to print       *)
BEGIN
  SendCh( #13);
  colCnt := 1;
  SendCh( #10);
  INC( lineCnt);
  IF (lineCnt >= lpp) THEN BEGIN     (* beyond lines per page? *)
     NextPage;
  END;
  IF totalBytes > 11500 THEN BEGIN           (* about 12000 ... *)
    IF dest = norton THEN BEGIN
      SendStr( ShortString);                 (* chop to pieces *)
    END;
    totalBytes := 0;
  END;
END;

PROCEDURE CheckColumn;         (* check next printing position *)
BEGIN
  IF (colCnt > cpl) AND        (* beyond columns per line?     *)
     (dest IN [printer, necP6, norton]) THEN
  BEGIN
     NextLine;
  END;
  IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
    PrintTitle;
  END;
  IF colCnt=1 THEN BEGIN
    LeftMargin;
  END;
END;

PROCEDURE CheckTopOfForm;                   (* at top of form? *)
BEGIN
  IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
    PrintTitle;
  END;
END;

PROCEDURE ListCh( c:CHAR);     (* all characters to be printed *)
                               (* and formatted have to pass   *)
BEGIN                          (* this filter                  *)
  IF c = #10 THEN BEGIN
     CheckTopOfForm;           (* print title, if at line 1    *)
     NextLine;
     EXIT;
  END;
  IF c IN printSet THEN BEGIN  (* Is it a printable character? *)
     CheckColumn;              (* end of line or pos 1?        *)
     SendCh( c);               (* finally send char            *)
     INC( colCnt);             (* adjust column counter        *)
  END;
  IF (c = '^') AND (dest=norton) THEN BEGIN
    SendCh('^');     (* send double up arrow for norton guides *)
  END;
  IF c = #9 THEN BEGIN         (* tabulator?                   *)
    ListCh(' ');               (* RECURSION!                   *)
    WHILE ((colCnt-lMargin) MOD tabLen) <> 1 DO BEGIN
      ListCh(' ');             (* tab to pos 1,9,17 ...        *)
    END;
  END;
  (* ignore unprintable characters here! *)
END;

PROCEDURE ListString( s:STRING);      (* send string to ListCh *)
VAR
  ch: CHAR;
BEGIN
  FOR ch := #1 TO s[0] DO BEGIN
    ListCh( s[ ORD(ch)] );
  END;
END;

PROCEDURE InitPrinting;
BEGIN                           (* set up defaults             *)
  colCnt  := 1;                 (* column count                *)
  lineCnt := 1;                 (* line count                  *)
  pageCnt := 1;                 (* page count                  *)
  lMargin := 0;                 (* # of blanks for left margin *)
  totalBytes := 0;
  shortCnt   := 0;
  inComment  := FALSE;
  inKeyWord  := FALSE;
  CASE dest OF

  datei: BEGIN
      lpp     := $FFFF;             (* not relevant            *)
      cpl     := $FFFF;             (* not relevant            *)
    END;

  console: BEGIN                    (* To screen:              *)
      lpp     := 24;                (* stop after 24 lines     *)
      cpl     := 80;                (* 80 columns per line     *)
      SendStr( #13#10#10);          (* start with empty line   *)
    END;

  printer: BEGIN                    (* To standard printer:    *)
     lpp     := 66;                 (* lines per page          *)
     cpl     := 80;                 (* columns per line        *)
     lMargin := 8;                  (* 8 * 0.254 cm = 2.032 cm *)
    END;

  norton: BEGIN                           (* To norton guides: *)
     lMargin := 1;                        (* much better!        *)
     lpp     := $FFFF;
     cpl     := 77;                   (* links + rechts 1 #32  *)
     SendStr( ShortString);           (* start 1st short entry *)
     SendStr( '^B'+f1Name+            (* and include file name *)
              '^N'#13#10#13#10);
    END;

  necP6: BEGIN
    SendStr(#27#0);            (* reset printer                *)
    SendStr(#27'R'#0);         (* american fontset             *)
    SendStr(#27'M');           (* 12 CPI = 96 cpl              *)
    SendStr(#27'l'#12);        (* left margin                  *)
    lpp     := 69;             (* use 69 of 72                 *)
    cpl     := 80;             (* columns per line (12+80+4)   *)
    lMargin :=  0;             (* hardware left margin         *)
    END;
  END; (* case *)
END;

PROCEDURE CondFF;                     (* conditional form feed *)
BEGIN                                 (* avoid empty page      *)
  IF dest IN [necP6, printer] THEN BEGIN
     IF (colCnt > 1) OR (lineCnt > 1) THEN BEGIN
       NextPage;
     END;
  END;
END;

PROCEDURE Angaben;          (* get parameters from commandline *)
VAR
  par3:  STRING;
BEGIN
  convert := (Pos('-C',UpStr(ParamStr(4)))=0);  (* convertflag *)
  f1Open := FALSE;
  f2Open := FALSE;
  f1Name := ParamStr( 1);                 (* input filename    *)
  f1Name[1] := UpCase( f1Name[1]);        (* 1st char to upper *)
  IF Pos('.',f1Name) = 0 THEN BEGIN       (* check for .PAS    *)
     f1Name := f1Name + '.PAS';
  END;
  Assign( f1File, f1Name);
  (*$I-*)
  Reset( f1File);                         (* open INPUT file   *)
  (*$I+*)
  IF IOResult <> 0 THEN BEGIN
    AbortProgram('PPP - Error: file '#39+f1Name+#39' not found');
  END;
  f1Open := TRUE;

  IF ParamCount > 1 THEN
    f2Name := UpStr( ParamStr(2))          (* output file name *)
  ELSE BEGIN
    f2Name:='CON';                         (* CON is default   *)
  END;
  IF (Pos('.',f2Name)=0) AND           (* copy Ext from input? *)
     ('CON' <> f2Name)   AND
     ('PRN' <> f2Name)   THEN
  BEGIN
    f2Name := f2Name+Copy( f1Name, Pos('.',f1Name),255);
  END;
  IF UpStr(f1Name) = UpStr(f2Name) THEN BEGIN
    AbortProgram('PPP - Error: In- and output file '#39 +
                   f1Name + #39' identically');
  END;
  IF f2Name = 'CON' THEN
    AssignCrt( f2File)                     (* use CRT          *)
  ELSE BEGIN
    Assign(  f2File, f2Name);
  END;
  IF Pos('-A', UpStr(ParamStr(4)))>0 THEN BEGIN
    (*$I-*)
    Append( f2File);                                 (* Append *)
    (*$I+*)
    IF IOResult=0 THEN BEGIN
      f2Open := TRUE;
    END;
  END;
  IF NOT f2Open THEN BEGIN
    (*$I-*)
    Rewrite( f2File);                               (* Rewrite *)
    (*$I+*)
    IF IOResult = 0 THEN BEGIN
      f2Open := TRUE;
    END;
  END;
  IF NOT f2Open THEN BEGIN
    AbortProgram('PPP - Error while opening file '+
                  #39+f2Name+#39);
  END;
  IF ParamCount > 2 THEN
      par3 := UpStr( ParamStr(3))          (* find destination *)
  ELSE BEGIN
    par3 := '';                            (* defaults ...     *)
    IF f2Name='CON' THEN par3 := 'CON';
    IF f2Name='PRN' THEN par3 := 'PRN';
  END;
  dest := datei;
  IF par3 = 'CON'     THEN BEGIN dest:=console; EXIT; END;
  IF par3 = 'NECP6'   THEN BEGIN dest:=necP6;   EXIT; END;
  IF par3 = 'PRN'     THEN BEGIN dest:=printer; EXIT; END;
  IF par3 = 'NORTON'  THEN BEGIN dest:=norton;  EXIT; END;
END;

PROCEDURE GetCh;             (* read next char from INPUT file *)
BEGIN
  IF Eof( f1File) THEN BEGIN
    IF colCnt <> 1 THEN BEGIN
      SendStr( #13#10);                         (* finish line *)
    END;
    AbortProgram('PPP - WARNING: unexpected end of file');
  END;
  Read( f1File, ch);
END;

PROCEDURE Copy;
BEGIN
  ListCh(  ch);                  (* current char to formatter  *)
  GetCh;                         (* get next one               *)
END;

FUNCTION NoKeyWord:BOOLEAN;    (* Binary search. Returns TRUE, *)
VAR                            (* if current identifier is not *)
  i,l,r,m: WORD;               (* a keyword                    *)
BEGIN
  l := 1;
  r := nKeyWords;
  id[ idPos] := ' ';           (* mark end of identifier       *)
  REPEAT
    m:=(l+r) DIV 2;
    keyIndex := m;
    i:=1;
    WHILE (UpCase(id[i])=UpCase(key[m,i])) AND
          (id[i] <> ' ') DO
    BEGIN
      INC( i);
    END;
    IF UpCase(id[i])<=UpCase(key[m,i]) THEN BEGIN r:=m-1; END;
    IF UpCase(id[i])>=UpCase(key[m,i]) THEN BEGIN l:=m+1; END;
  UNTIL l>r;
  NoKeyWord := (l=r+1);      (* TRUE if identifier = NoKeyWord *)
END;

PROCEDURE ProcessText;               (* whole input file       *)
PROCEDURE ProcessChar;               (* deal with current char *)
PROCEDURE Comment1;                  (* process ( * comment    *)
BEGIN
  Copy;                              (* process '*'            *)
  REPEAT
    WHILE ch <> '*' DO BEGIN         (* look for final '*'     *)
      Copy;
    END;
    Copy;
  UNTIL ch=')';                (* does ')' follow immediately? *)
  Copy;
END;

PROCEDURE ProcessUpTo( endCh: CHAR); (* copy until endCh found *)
BEGIN
  Copy;
  WHILE ch <> endCh DO BEGIN
    Copy;
  END;
  Copy;
END;

PROCEDURE Collect;         (* collect chars to form identifier *)
VAR
  i: WORD;
BEGIN
  idPos := 1;
  REPEAT
    id[ idPos] := ch;
    INC( idPos);
    GetCh;
  UNTIL (NOT( ch IN idSet)) OR (idPos > KeyWordLength);

  IF (idPos > keyWordLength) OR       (* shortcut evaluation   *)
      NoKeyWord THEN                  (* MUST be ON! {$B-}     *)
  BEGIN
    FOR i := 1 TO idPos-1 DO BEGIN    (* NO keyword!           *)
      ListCh(  id[i]);                (* print collected stuff *)
    END;
    EXIT;
  END;
                                    (* keyword found           *)
  color := Ord( key[ keyIndex,      (* find keyword class      *)
           idPos+1]) - Ord('1');
  color := (color + 2) MOD 8;       (* make sure: 0..7         *)
  KeyWordOn;                        (* signal start of keyword *)
  FOR i:=1 TO idPos-1 DO BEGIN
    ListCh( key[ keyIndex, i]);     (* print keyword           *)
  END;
  KeyWordOff;                       (* signal end of keyword   *)
END; (* Collect *)

BEGIN (* ProcessChar *)
  IF NOT convert THEN BEGIN           (* conversion inhibited? *)
    Copy;                             (* yes, so copy only     *)
    EXIT;
  END;
  IF (UpCase(ch)>='A') AND
     (UpCase(ch)<='Z') THEN
  BEGIN
     Collect;                         (* collect identifier    *)
     EXIT;
  END;
  IF ch = '(' THEN BEGIN       { a '(*' comment?                }
     GetCh;
     IF ch = '*' THEN BEGIN
       CommentOn;              (* signal start of comment      *)
       ListCh('(');
       Comment1;               (* process this kind of comment *)
       CommentOff;             (* signal end of comment        *)
       EXIT;
     END
     ELSE BEGIN
       ListCh('(');
       EXIT;
     END;
  END;
  IF ch = '{' THEN BEGIN       (* a '{' comment?               *)
     CommentOn;                (* signal start of comment      *)
     ProcessUpTo( '}');        (* process this kind of comment *)
     CommentOff;               (* signal end of comment        *)
     EXIT;
  END;
  IF ch = #39 THEN BEGIN
       ProcessUpTo( #39);      (* process string constant      *)
     EXIT;
  END;
  Copy;                        (* nothing special, so copy!    *)
END; (* ProcessChar *)

BEGIN (* ProcessText *)
  lk     := #0;                            (* last key pressed *)
  goFlag := #13;                           (* #32 = ' ' = go   *)
  GetCh;                                   (* provide 1st char *)
  WHILE NOT(Eof(f1File)) AND
        (lk<>#27) DO
  BEGIN
    ProcessChar;
    lk     := LastKey;                     (* check keyboard   *)
    IF lk <> #0 THEN BEGIN                 (* key pressed?     *)
      goFlag := lk;                        (* save pressed key *)
      IF (goFlag<>' ') AND
         (dest=console) THEN
      BEGIN
        lineCnt := 9999;              (* pause after next line *)
      END;
    END;
  END;
END;  (* ProcessText *)

PROCEDURE Help;             (* redirect to printer with CTRL+P *)
BEGIN
WriteLn;
WriteLn('PPP - Pretty Print Pascal. Autor: Martin Blea 890224');
WriteLn('====================================================');
WriteLn(
'correct start: PPP [file] [to] [how] [switches]');
WriteLn(
'        Example:  PPP Test.pas prn necp6  -p');
WriteLn;
WriteLn(' file: file name of source.       (1. Parameter)');
WriteLn('       '#39'.PAS'#39' will be added if necessary.');
WriteLn;
WriteLn(' to:   output filename or device. (2. Parameter)');
WriteLn('       (nothing)      = output to screen');
WriteLn('       CON            = output to screen');
WriteLn('       PRN            = output to printer');
WriteLn(' how:                             (3. Parameter)');
WriteLn('       (nothing)      = suitable for destination file');
WriteLn('       CON            = screen like');
WriteLn('       NECP6          = NEC P6 Printer like.');
WriteLn('       NORTON         = for NORTON-Guides');
WriteLn('       PRN            = vanilla printer');
WriteLn;
WriteLn(' switches:            (without spaces, 4. Parameter)');
WriteLn('       -A             = append to destination file');
WriteLn('       -C             = no keyword conversion');
WriteLn('       -P             = no form-feed (FF) after last page');
END;

BEGIN
  Assign( OutPut, '');       (* allow redirection of help text *)
  Append( OutPut);           (* append, the saver way ...      *)
  IF ParamCount < 1 THEN     (* PPP = 0 args, give help        *)
  BEGIN
    Help;
    Halt(0);                 (* assume no error                *)
  END;
  Angaben;                   (* get parameters and initialize  *)

  (*$IFDEF sort  *) SortKeyWords; (*$ENDIF*)
  (*$IFDEF debug *) ShowKeyWords; (*$ENDIF*)

  InitPrinting;                (* setup parameters and devices *)
  ProcessText;                 (* process the INPUT file       *)
  IF colCnt <> 1 THEN BEGIN    (* print head not at pos 1?     *)
    ListCh( #10);              (* finish line                  *)
  END;
  IF Pos('-P', UpStr(
       ParamStr(4)))=0 THEN
  BEGIN                        (* final FF?                    *)
    CondFF;                    (* only, if not already at      *)
  END;                         (*   end of page                *)
  AbortProgram( '');           (* Shut down.                   *)
END.                           (*   No message = No Error      *)