DAVID%UCONNVM.BITNET@cunyvm.cuny.edu (12/04/89)
I am looking for some help in correcting a rather stupid error. I downloaded PPP, a Pretty Printer for Pascal, from Michael Keukert, and inadvertantly printed it and erased the file. Rather than ask for immediate help, I tried to scan the printing in (which worked) and re-create the program. However, the font of the mainframe printer here prints "one" and "l" as the same, so I arrived at a corrupted pascal source which I can't fix. So, can I request someone who saved a copy of this pretty printer to send me a copy again? Thanks, Carl David (DAVID at UCONNVM.bitnet)
chris@tadhg.newcastle.ac.uk (Chris Forker - Nav Arch-) (12/05/89)
In article <21629@adm.BRL.MIL> DAVID%UCONNVM.BITNET@cunyvm.cuny.edu writes: >I am looking for some help in correcting a rather stupid error. >I downloaded PPP, a Pretty Printer for Pascal, from Michael Keukert, and >inadvertantly printed it and erased the file. >Rather than ask for immediate help, I tried to scan the printing in >(which worked) and re-create the program. >However, the font of the mainframe printer here prints "one" and "l" >as the same, so I arrived at a corrupted pascal source which I can't >fix. >So, can I request someone who saved a copy of >this pretty printer to send me a copy again? >Thanks, >Carl David (DAVID at UCONNVM.bitnet) From ukc!mcsun!unido!rwthinf!cip-s02.informatik.rwth-aachen.de!pmk Mon Nov 27 10:23:58 GMT 1989 Article 2450 of comp.lang.pascal: Path: newcastle.ac.uk!ukc!mcsun!unido!rwthinf!cip-s02.informatik.rwth-aachen.de!pmk >From: pmk@cip-s02.informatik.rwth-aachen.de (Michael Keukert) Newsgroups: comp.lang.pascal Subject: Pretty print pascal Message-ID: <1720@rwthinf.UUCP> Date: 24 Nov 89 12:33:28 GMT Sender: news@rwthinf.UUCP Reply-To: pmk@cip-s02.informatik.rwth-aachen.de (Michael Keukert) Organization: Informatik RWTH Aachen Lines: 844 Now following the desired Pretty-Print-Pascal. Instructions: type ppp.exe in your command-line and the programm will give instructions by itself. Found in : c't Magazin fuer Computer & Technik 9/89 (* 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, (* 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 - Fehler bei der Ausgabe nach '#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'); (* Schattenschrift EIN *) 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'); (* Schattenschrift AUS *) 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; (* nchste Druckseite *) 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), '(Leer-) Taste ...'); 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; (* nchste Druckzeile *) 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 (* rund 12000 ... *) IF dest = norton THEN BEGIN SendStr( ShortString); (* chop to pieces *) END; totalBytes := 0; END; END; PROCEDURE CheckColumn; (* nchste Druckposition prfen *) 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; (* besser so! *) 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); (* Drucker normieren *) SendStr(#27'R'#0); (* amerik. Zeichensatz *) SendStr(#27'M'); (* 12 CPI = 96 cpl *) SendStr(#27'l'#12); (* linker Rand *) 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 - Fehler: Datei '#39+f1Name+#39' nicht gefunden'); 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 - Fehler: Ein- und Ausgabedatei '#39 + f1Name + #39' identisch'); 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 - Fehler beim ffnen der Datei '+ #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 - WARNUNG: unerwartetes Datei-Ende'); 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( 'Korrekter Aufruf: PPP von <nach> <wie> <schalter>'); WriteLn( ' Beispiel: PPP Test.pas prn necp6 -p'); WriteLn; WriteLn(' von: DateiName des Quelltextes. (1. Parameter)'); WriteLn(' '#39'.PAS'#39' wird ggf. ergnzt.'); WriteLn; WriteLn(' nach: Dateiname der Ausgabe. (2. Parameter)'); WriteLn(' (keine Angabe) = Ausgabe zum Bildschirm'); WriteLn(' CON = Ausgabe zum Bildschirm'); WriteLn(' PRN = Ausgabe zum Drucker'); WriteLn(' wie: (3. Parameter)'); WriteLn(' (keine Angabe) = passend fr Ziel-Datei'); WriteLn(' CON = fr Bildschirm'); WriteLn(' NECP6 = fr Drucker NEC-P6 und hn.'); WriteLn(' NORTON = fr NORTON-Guides'); WriteLn(' PRN = fr Standard-Drucker'); WriteLn; WriteLn(' schalter: (ohne Leerstellen, 4. Parameter)'); WriteLn(' -A = Anfgen an die Ausgabedatei'); WriteLn(' -C = keine Schlsselwort-Konvertierung'); WriteLn(' -P = kein Seitenvorschub am Ende'); 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 *) PMK@CIP-S01.INFORMATIK.RWTH-AACHEN.DE Phone private: +49 241 513297 Michael Keukert of 2:242/7 (Fido-Net) Phone office : +49 241 80-7574 PMK@EIKO.ZER (Zerberus-Net) Telefax : +49 241 158597 (mark "DES Mr. M.Keukert" on your fax) hope this helps Chris.... +-=--=--=--=--=--=--=--=--=--=--=--=--=--+--=--=--=--=--=--=--=--=--=--=--=-+ | mail: Chris.Forker@newcastle.ac.uk | Dept. Marine Technology | | voice: +44 91 2226000 X 6750 | Newcastle University | | fax: +44 91 2611182 | Newcastle upon Tyne | | | NE1 7RU ENGLAND | +-=--=--=--=--=--=--=--=--=--=--=--=--=--+--=--=--=--=--=--=--=--=--=--=--=-+