|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 58759 (0xe587)
Types: TextFile
Names: »PASCFORM.PAS«
└─⟦e2123b2a1⟧ Bits:30010498 DVBS1.SW2103.src.1.8-1 Pascal TOOLS JTAS 1989-04-26 LEIF NIELSEN E.d.
└─⟦this⟧ »PASCFORM.PAS«
{[A=20,B+,R=1-140,I=2,S=2,W=1-80] FORMATTERDIRECTIVES. }\r
\r
{$R-,S-,I+,F-,V+,B-,N-,L+ }\r
PROGRAM Format(Input, Output);\r
{\r
*************************************************************\r
* *\r
* P A S C A L P R O G R A M F O R M A T T E R *\r
* ----------------------------------------------- *\r
* *\r
* Author: Michal N. Condict, 1975. *\r
* Lehigh University *\r
* *\r
* Updated: August 1978. *\r
* August 1988 by *\r
* Hans J. Jakobsen, Aarhus, Denmark *\r
* *\r
*************************************************************\r
\r
Date: Init. Ver. Explanation.\r
\r
\r
1988-10-19 LEI 1.4 Parameter processing made by Leif Nielsen, JTAS\r
1989-02-06 HJJ 1.5 Skip control characters ( ord(ch) < 32 );\r
------------------------------------------------------------------------------}\r
\r
USES\r
Param,\r
Dosutil,\r
Help;\r
{$M 16384, 0, 655360 }\r
\r
CONST\r
Version = ('1.5');\r
File_Buff_size = 2048;\r
\r
{$I pascf1.pas}\r
\r
PROCEDURE WriteA(Character: Char);\r
\r
VAR\r
I: Width;\r
TestNo: Integer;\r
\r
BEGIN\r
CharCount := CharCount + 1; Oldest := (Oldest +1) MOD BufferSize;{ Oldest := Charcount mod BufferSize;}\r
WITH UnWritten[Oldest] DO\r
BEGIN\r
IF CharCount > BuffSzP1\r
THEN\r
BEGIN\r
IF ChIsEndLine\r
THEN\r
BEGIN\r
IF IndentAfterEOL < 0\r
THEN\r
BEGIN\r
{ Write('(: ',IndentAfterEOL,' :)');}\r
Write(' ': -IndentAfterEOL);\r
OutputCol := OutputCol - IndentAfterEOL;\r
END\r
ELSE\r
BEGIN\r
IF Increment < 0\r
THEN\r
BEGIN\r
I := WriteRightCol - OutputCol + 1;\r
IF I > 0 THEN Write(' ': I);\r
TestNo := LineNumber; I := 0;\r
REPEAT TestNo := TestNo DIV 10; I := I + 1;\r
UNTIL TestNo = 0;\r
FOR TestNo := 1 TO (6-I) DO Write('0');\r
Write(LineNumber:I);\r
LineNumber := LineNumber - Increment;\r
IF LineNumber > 9999\r
THEN LineNumber := LineNumber - 10000;\r
Writeln;\r
END\r
ELSE\r
BEGIN\r
WriteLn;\r
IF Increment > 0\r
THEN\r
BEGIN\r
Write(LineNumber: 4, ' ');\r
LineNumber := LineNumber + Increment;\r
END;\r
END;\r
IF IndentAfterEOL > 0\r
THEN Write(' ': IndentAfterEOL);\r
OutputCol := IndentAfterEOL + 1;\r
END {Else };\r
ChIsEndLine := False;\r
END {If ChIsEndLine }\r
ELSE\r
BEGIN Write(ch); OutputCol := OutputCol + 1;\r
END {Else};\r
END {If Charcount >};\r
Ch := Character; WriteColumn := WriteCoLumn + 1;\r
END {With};\r
END {WriteA};\r
\r
\r
PROCEDURE FlushUnwrittenBuffer;\r
\r
BEGIN\r
WriteA(' ');\r
WITH UnWritten[Oldest] DO\r
BEGIN ChIsEndLine := True; IndentAfterEOL := 0; END;\r
WriteColumn := 0; FOR I := 0 TO BuffSzM1 DO WriteA(' ');\r
END {FlushUnwrittenBuffer};\r
\r
\r
PROCEDURE StartNewLineAndIndent;\r
\r
BEGIN\r
IF PackerIsOff AND DisplayIsOn\r
THEN\r
BEGIN\r
WriteA(' '); LastSymbol := PeriodSymbol;\r
WITH UnWritten[Oldest] DO\r
BEGIN\r
ChIsEndLine := True;\r
IndentAfterEOL := WriteLeftCol + LeftMargin - 1;\r
END;\r
WriteColumn := WriteLeftCol + LeftMargin;\r
END {If PackerIsOff};\r
END {StartNewLineAndIndent};\r
\r
\r
PROCEDURE ReadACharacter;\r
\r
BEGIN\r
IF readColumn > ReadRightCol\r
THEN\r
BEGIN\r
IF readRightCol < MaxReadRightCol\r
THEN BEGIN NextChISEOL := True; ReadLn END\r
ELSE ReadColumn := 2;\r
END\r
ELSE\r
IF ReadColumn = 1 THEN\r
WHILE ReadColumn < ReadLeftCol DO\r
BEGIN\r
IF Eoln(Input) THEN ReadColumn := 1\r
ELSE BEGIN ReadColumn := ReadColumn + 1; GetInput END\r
END;\r
IF NextChIsEOL\r
THEN\r
BEGIN\r
Character := ' '; NextChIsEOL := False; ChIsEOL := True;\r
ReadColumn := 1;\r
IF NoFormatting\r
THEN\r
BEGIN\r
WriteA(' ');\r
WITH UnWritten[Oldest] DO\r
BEGIN\r
ChIsEndLine := True;\r
IndentAfterEOL := WriteLeftCol - 1;\r
END;\r
WriteColumn := WriteLeftCOl;\r
END;\r
END\r
ELSE\r
IF NOT EOF(Input)\r
THEN\r
BEGIN\r
Character := InputPtr; ReadColumn := ReadColumn + 1;\r
NextChIsEOL := Eoln(Input); GetInput; ChIsEOL := False;\r
IF NoFormatting THEN WriteA(Character);\r
END\r
ELSE BEGIN FlushUnWrittenBuffer; Writeln('*** Input Exceeded '); Halt END;\r
{ Writeln('ReadACharacter.''',Character,'''');}\r
END {ReadACharacter};\r
\r
\r
PROCEDURE WriteSymbol;\r
\r
VAR\r
I: Width;\r
NumberBlanksToWrite: OptionSize;\r
\r
BEGIN\r
IF DisPlayIsOn\r
THEN\r
BEGIN\r
NumberBlanksToWrite := SymbolGap;\r
IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR\r
(SymbolName IN [SemiColon, RightParenth, RightBracket,\r
CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN\r
[LeftBracket, LeftParenth]) AND (LastSymbol = Identifier)\r
THEN NumberBlanksToWrite := 0\r
ELSE\r
IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN\r
AlphaSymbols)\r
THEN\r
IF WriteColumn <= WriteRightCol THEN\r
BEGIN WriteA(' '); NumberBlanksToWrite := SymbolGap - 1;\r
END;\r
IF WriteColumn + Length + NumberBlanksToWrite - 1 >\r
WriteRightCol\r
THEN\r
BEGIN\r
WriteA(' ');\r
WITH UnWritten[Oldest] DO\r
BEGIN\r
ChIsEndLine := True;\r
IF PackerIsOff\r
THEN\r
BEGIN\r
IF WriteLeftCol + LeftMargin + LongLineIndent +\r
Length - 1 > WriteRightCol\r
THEN Length := 10;\r
IndentAfterEOL := WriteLeftCol - 1 + LeftMargin +\r
LongLineIndent;\r
WriteColumn := WriteLeftCol + LeftMargin +\r
LongLineIndent;\r
END\r
ELSE\r
BEGIN\r
IF Length > WriteRightCol - WriteLeftCol + 1\r
THEN Length := WriteRightCol - WriteLeftCol + 1;\r
IndentAfterEol := WriteLeftCol - 1;\r
WriteColumn := WriteLeftCol;\r
END\r
END {With};\r
END\r
ELSE FOR I:= 1 TO NumberBlanksToWrite DO WriteA(' ');\r
FOR I := 1 TO Length DO WriteA( Symbol[I]);\r
END {If DisplayIsOn};\r
LastSymbol := SymbolName;\r
END {WriteSymbol};\r
\r
\r
PROCEDURE CopyACharacter;\r
\r
BEGIN\r
IF DisplayIsOn\r
THEN\r
BEGIN\r
IF WriteColumn > WriteRightCol THEN\r
BEGIN\r
WHILE (Character = ' ') AND NOT ChIsEOL DO\r
ReadAcharacter;\r
IF NOT ChIsEOL THEN StartNewLineAndIndent;\r
END;\r
IF ChIsEOL\r
THEN\r
BEGIN\r
LeftMargin := 0; StartNewLineAndIndent;\r
LeftMargin := ActualLeftMargin;\r
ReadACharacter {Skip Space at Eol};\r
END\r
ELSE WriteA(Character);\r
END;\r
ReadACharacter\r
END {CopyACharacter};\r
\r
\r
PROCEDURE DoFormatterDirectives;\r
\r
CONST\r
Invalid = -1;\r
\r
TYPE\r
ParamCount = 1 .. 2;\r
Params = ARRAY [ParamCount] OF Integer;\r
\r
VAR\r
Specification: Params;\r
FormatOption: Char;\r
PrevDisplay,\r
PrevNoFormatting:Boolean;\r
EndDirectv: CharSet;\r
\r
PROCEDURE ReadIn(N: ParamCount; VAR Specification: Params);\r
\r
VAR\r
I: ParamCount;\r
\r
BEGIN\r
FOR I := 1 TO N DO\r
BEGIN\r
WHILE NOT (Character IN (TenDigits + EndDirectv)) DO\r
CopyAcharacter;\r
Specification [I] := 0;\r
IF NOT (Character IN EndDirectv)\r
THEN\r
REPEAT\r
Specification[I] := 10 * Specification[I] + ord(Character)\r
- ord('0');\r
CopyACharacter;\r
UNTIL NOT (Character IN TenDigits)\r
ELSE Specification[I] := Invalid;\r
END {For};\r
END {ReadIn};\r
\r
\r
BEGIN {DoFormatterDirectives}\r
EndDirectv := [ '*', ']' ];\r
REPEAT\r
IF Character IN ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'I', 'L', 'N',\r
'P', 'R', 'S', 'W' ]\r
THEN\r
BEGIN\r
FormatOption := Character;\r
CASE FormatOption OF\r
'A', 'E', 'I', 'G', 'P', 'L', 'S':\r
BEGIN\r
ReadIn(1, Specification);\r
IF (Specification[1] < WriteRightCol - WriteLeftCol - 9)\r
OR (FormatOption = 'P')\r
THEN\r
CASE FormatOption OF\r
'A': DeclarAlignment := Specification[1];\r
'E':\r
IF Specification [1] < 4 THEN\r
BEGIN\r
ProcNamesWanted := Specification[1] > 1;\r
EndCommentsWanted := Odd(Specification[1]);\r
END;\r
'G': SymbolGap := Specification[1];\r
'I': IndentIndex := Specification[1];\r
'L': LongLineIndent := Specification[1];\r
'P': ProcSeparation := Specification[1];\r
'S': StatmtSeparation := Specification[1];\r
END {Case};\r
END {Single Parameters};\r
'W', 'R', 'N':\r
BEGIN\r
ReadIn(2, Specification);\r
IF Specification[2] <> Invalid\r
THEN\r
CASE FormatOption OF\r
'W':\r
IF (Specification[1] > 0) AND (Specification[2] <\r
BufferSize - 2) AND (Specification[2] -\r
Specification[1] > 8)\r
THEN\r
BEGIN\r
WriteLeftCol := Specification[1];\r
WriteRightCol := Specification[2];\r
END;\r
'R':\r
IF (Specification[1] > 0) AND (Specification[2] -\r
Specification[1] > 8)\r
THEN\r
BEGIN\r
ReadLeftCol := Specification[1];\r
ReadRightCol := Specification[2];\r
END;\r
'N':\r
BEGIN\r
LineNumber := Specification[1];\r
Increment := Specification[2];\r
WHILE NOT ( Character IN (['<'] + EndDirectv))\r
AND (Character <> '>') DO\r
CopyACharacter;\r
IF Character = '>'\r
THEN Increment := -Increment\r
END\r
END {Case};\r
END {Double Parameters};\r
'B', 'C', 'D', 'F':\r
BEGIN\r
REPEAT CopyACharacter;\r
UNTIL Character IN (['+', '-'] + EndDirectv);\r
IF Character IN [ '+', '-']\r
THEN\r
CASE FormatOption OF\r
'B':\r
IF DisplayIsOn\r
THEN BunchWanted := Character = '+';\r
'C': PackerIsOff := Character = '-';\r
'D':\r
BEGIN\r
PrevDisplay := DisplayIsOn;\r
DisplayIsOn := Character = '+';\r
IF PrevDisplay AND NOT DisplayIsOn\r
THEN\r
BEGIN\r
WriteA('*'); WriteA(')');\r
SavedBunch := BunchWanted;\r
BunchWanted := False;\r
END\r
ELSE\r
IF NOT PrevDisplay AND DisplayIsOn THEN\r
BEGIN\r
StartNewLineAndIndent; WriteA('(');\r
WriteA('*'); BunchWanted := SavedBunch;\r
END {If not Prev }\r
END { 'D': };\r
'F':\r
BEGIN\r
PrevNoFormatting := Noformatting;\r
NoFormatting := Character = '-';\r
DisplayIsOn := NOT NoFormatting;\r
IF PrevNoFormatting AND NOT NoFormatting\r
THEN ReadACharacter;\r
IF NOT PrevNoFormatting AND NoFormatting\r
THEN WriteA('-');\r
END;\r
END {Case};\r
END {Boolean Parameters}\r
END {Case}\r
END {Then}\r
ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter;\r
UNTIL Character IN EndDirectv;\r
IF (Character = ']') THEN CopyACharacter;\r
END {DoFormatterDirectives};\r
\r
\r
PROCEDURE ReadSymbol;\r
\r
CONST\r
ReadNextCh = true;\r
DontReadNextCh = False;\r
\r
VAR\r
TestSymbol: Alfa;\r
CharNumber: Width;\r
I: Width;\r
\r
PROCEDURE SkipComment(CommentStart: CommentType);\r
\r
BEGIN\r
IF NestedComments IN Language THEN\r
CASE CommentStart OF\r
Starcomment:\r
REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter\r
UNTIL Character = ')';\r
AngleComment:\r
REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter\r
UNTIL Character = '>';\r
CurlyComment:\r
WHILE Character <> '}' DO ReadACharacter;\r
EolComment:\r
REPEAT ReadACharacter UNTIL ChIsEol;\r
END\r
ELSE\r
REPEAT\r
WHILE NOT (Character IN ['*', '}']) DO ReadACharacter;\r
IF Character = '*' THEN ReadACharacter;\r
UNTIL Character IN [')', '}'];\r
\r
ReadACharacter; LastSymbol := Comment; ReadSymbol\r
END {SkipComment};\r
\r
PROCEDURE DoComment(CommentStart: CommentType);\r
\r
VAR\r
I: OptionSize;\r
\r
\r
PROCEDURE CompilerDirectives;\r
\r
BEGIN REPEAT CopyACharacter; UNTIL Character IN ['[', '*', '}']\r
END {CompilerDirectives};\r
\r
BEGIN {DoComment}\r
BEGIN\r
IF LastSymbol IN [Comment, SemiColon] THEN\r
BEGIN\r
LeftMargin := 0; StartNewLineAndIndent;\r
LeftMargin := ActualLeftMargin;\r
END;\r
WriteSymbol; IF Character = '$' THEN CompilerDirectives;\r
IF Character = '[' THEN DoFormatterDirectives;\r
IF NestedComments IN Language THEN\r
CASE CommentStart OF\r
StarComment:\r
REPEAT WHILE Character <> '*' DO CopyACharacter; CopyACharacter\r
UNTIL Character = ')';\r
AngleComment:\r
REPEAT WHILE Character <> '*' DO CopyACharacter; CopyACharacter\r
UNTIL Character = '>';\r
CurlyComment:\r
WHILE Character <> '}' DO CopyACharacter;\r
EolComment:\r
REPEAT CopyACharacter UNTIL ChIsEol;\r
END\r
ELSE\r
REPEAT\r
WHILE NOT (Character IN ['*', '}']) DO CopyACharacter;\r
IF Character = '*' THEN CopyACharacter;\r
UNTIL Character IN [')', '}'];\r
CopyACharacter; LastSymbol := Comment; ReadSymbol;\r
END;\r
END {DoComment};\r
\r
\r
PROCEDURE CheckFor(SecondChar: Char; TwoCharSymbol: Symbols;\r
ReadAllowed: Boolean);\r
\r
BEGIN\r
IF ReadAllowed THEN\r
BEGIN\r
Length := 1; Symbol[1] := Character;\r
SymbolName := NameOf[Character]; ReadACharacter;\r
END;\r
IF Character = SecondChar\r
THEN\r
BEGIN\r
Symbol[2] := Character; Length := 2;\r
SymbolName := twoCharSymbol; ReadACharacter;\r
IF (NOT PackerIsOff) AND (SymbolName = Comment)\r
THEN Length := 0\r
END;\r
END {CheckFor};\r
\r
\r
BEGIN {ReadSymbol}\r
IF (Character IN [ 'A'..'Z', 'a'..'z', '0'..'9', ' ', '(', '.', ':', '''',\r
'<', '>', '{', '-', '"', '#', '$' ])\r
THEN\r
CASE Character OF\r
'(':\r
BEGIN\r
CheckFor('*', Comment, ReadNextCh);\r
IF (SymbolName = Comment) THEN\r
BEGIN\r
IF PackerIsOff THEN DoComment(StarComment)\r
ELSE IF SymbolName= Comment THEN Skipcomment(StarComment);\r
END\r
ELSE\r
CheckFor('.', LeftBracket, DontReadNextCh);\r
END;\r
'-':\r
BEGIN\r
CheckFor('-', Comment, ReadNextCh);\r
IF (SymbolName = Comment) THEN\r
BEGIN\r
IF PackerIsOff THEN DoComment(EolComment)\r
ELSE IF SymbolName= Comment THEN Skipcomment(EolComment);\r
END;\r
END;\r
'{':\r
BEGIN\r
SymbolName := Comment;\r
CharNumber := 1;\r
Symbol[1] := Character;\r
Length := 1;\r
ReadACharacter;\r
IF PackerIsOff THEN DoComment(CurlyComment)\r
ELSE Skipcomment(CurlyComment);\r
END;\r
'A'..'Z', 'a'..'z':\r
BEGIN\r
CharNumber := 1; SymbolIsNumber := False;\r
REPEAT\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
UNTIL NOT (Character IN LettersAndDigits);\r
Length := CharNumber - 1;\r
FOR CharNumber := Charnumber TO AlfaLeng DO\r
Symbol[CharNumber] := ' ';\r
{Pack(Symbol, 1, TestSymbol);}\r
FOR I := 1 TO Alfaleng DO\r
TestSymbol[I] := UpCase(Symbol[I]);\r
I := 1;\r
PascalSymbol[LastPascSymbol] := TestSymbol;\r
WHILE PascalSymbol[I] <> TestSymbol DO I := I + 1;\r
SymbolName := PascSymbolName[I];\r
END {Letter};\r
'0'..'9', '#', '$':\r
BEGIN\r
SymbolIsNumber := True; CharNumber := 1;\r
Digits := TenDigits;\r
IF Character = '#' THEN\r
BEGIN\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
IF Character IN ['h', 'H'] THEN Digits := HexDigits;\r
IF Character IN ['o', 'O'] THEN Digits := OctalDigits;\r
IF Character IN ['b', 'B'] THEN Digits := BinaryDigits;\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
END\r
ELSE\r
IF Character = '$' THEN\r
BEGIN\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
Digits := HexDigits;\r
END;\r
REPEAT\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
UNTIL NOT (Character IN Digits + ['.']);\r
IF Character IN [ 'B'.. 'E' ]\r
THEN\r
BEGIN\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
IF Character IN Digits + ['+', '-'] THEN\r
REPEAT\r
Symbol[CharNumber] := Character; ReadACharacter;\r
CharNumber := CharNumber + 1;\r
UNTIL NOT (Character IN Digits)\r
END;\r
Length := CharNumber - 1; SymbolName := Identifier;\r
END {Number};\r
' ':\r
BEGIN\r
REPEAT ReadACharacter UNTIL Character <> ' '; ReadSymbol\r
END;\r
'>', ':': CheckFor('=', OtherSymbol, ReadNextCh);\r
'<':\r
BEGIN\r
CheckFor('*', Comment, ReadNextCh);\r
IF (SymbolName = Comment) THEN\r
BEGIN\r
IF PackerIsOff THEN DoComment(AngleComment)\r
ELSE IF SymbolName= Comment THEN Skipcomment(AngleComment);\r
END\r
ELSE\r
BEGIN\r
CheckFor('=', OtherSymbol, DontReadNextCh);\r
IF SymbolName <> OtherSymbol\r
THEN CheckFor('>', OtherSymbol, DontReadNextCh);\r
END\r
END;\r
'.':\r
IF LastSymbol <> EndSymbol\r
THEN \r
BEGIN\r
CheckFor('.', Range, ReadNextCh);\r
IF SymbolName <> Range THEN\r
CheckFor(')', RightBracket, DontReadNextCh);\r
END\r
ELSE\r
SymbolName := PeriodSymbol;\r
'''':\r
BEGIN\r
CharNumber := 1;\r
REPEAT\r
REPEAT\r
Symbol[CharNumber] := Character;\r
CharNumber := CharNumber + 1; ReadACharacter;\r
UNTIL Character = '''';\r
Symbol[CharNumber] := Character;\r
CharNumber := CharNumber + 1; ReadACharacter;\r
UNTIL Character <> '''';\r
Length := Charnumber - 1; SymbolName := OtherSymbol;\r
IF Length > WriteRightCol - WriteLeftCol + 1\r
THEN\r
BEGIN\r
FlushUnwrittenBuffer; WriteLn;\r
WriteLn(' *** String too long.');\r
Halt;\r
END;\r
END {String};\r
'"':\r
BEGIN\r
CharNumber := 1;\r
REPEAT\r
REPEAT\r
Symbol[CharNumber] := Character;\r
CharNumber := CharNumber + 1; ReadACharacter;\r
UNTIL Character = '"';\r
Symbol[CharNumber] := Character;\r
CharNumber := CharNumber + 1; ReadACharacter;\r
UNTIL Character <> '"';\r
Length := Charnumber - 1; SymbolName := OtherSymbol;\r
IF Length > WriteRightCol - WriteLeftCol + 1\r
THEN\r
BEGIN\r
FlushUnwrittenBuffer; WriteLn;\r
WriteLn(' *** String too long.');\r
Halt;\r
END;\r
END {String};\r
END {Case}\r
ELSE\r
BEGIN\r
Symbol[1] := Character; SymbolName := NameOf[Character];\r
Length := 1; ReadACharacter;\r
END;\r
{ WriteLn('ReadSymbol:', Ord(SymbolName));}\r
END {ReadSymbol};\r
\r
\r
PROCEDURE ChangeMarginTo(NewLeftMargin: Margins);\r
\r
VAR\r
IndentedLeftMargin: Margins;\r
\r
BEGIN\r
ActualLeftMargin := NewLeftMargin; LeftMargin := NewLeftMargin;\r
IF LeftMargin < 0 THEN LeftMargin := 0\r
ELSE\r
BEGIN\r
IndentedLeftMargin := WriteRightCol - 9 - LongLineIndent;\r
IF LeftMargin > IndentedLeftMargin\r
THEN LeftMargin := IndentedLeftMargin\r
END;\r
{ writeln('(: ',ord(SymbolName),' LeftMargin: ',leftmargin,\r
' IndentedLeftMargin: ',IndentedLeftMargin,' :)');}\r
END {ChangeMarginTo};\r
\r
\r
PROCEDURE DoDeclarationUntil(EndDeclaration: SymbolSet);\r
\r
PROCEDURE DoParentheses;\r
\r
VAR\r
SavedLgLnId: OptionSize;\r
\r
BEGIN\r
SavedLgLnId := LongLineIndent;\r
IF DeclarAlignment > 0\r
THEN\r
BEGIN\r
LongLineIndent := WriteColumn + SymbolGap + 1 - LeftMargin -\r
WriteLeftCol;\r
REPEAT WriteSymbol; ReadSymbol;\r
UNTIL SymbolName = RightParenth;\r
WriteSymbol; ReadSymbol;\r
END\r
ELSE\r
BEGIN\r
LongLineIndent := 1;\r
ChangeMarginTo(ActualLeftMargin + IndentIndex);\r
StartNewLineAndIndent;\r
REPEAT WriteSymbol; ReadSymbol\r
UNTIL SymbolName = RightParenth;\r
WriteSymbol; ReadSymbol;\r
ChangeMarginTo(ActualLeftMargin - IndentIndex);\r
END {Else};\r
LongLineIndent := SavedLgLnId;\r
END {DoParentheses};\r
\r
\r
PROCEDURE DoFieldListUntil(EndFieldList: SymbolSet);\r
\r
VAR\r
LastEOL: Margins;\r
AlignColumn: Width;\r
\r
PROCEDURE DoRecord;\r
\r
VAR\r
SavedLeftMargin: Width;\r
\r
BEGIN\r
SavedLeftMargin := ActualLeftMargin; WriteSymbol; ReadSymbol;\r
ChangeMarginTo(WriteColumn - 6 + IndentIndex - WriteLeftCol);\r
StartNewLineAndIndent; DoFieldListUntil([EndSymbol]);\r
ChangeMarginTo(ActualLeftMargin - IndentIndex);\r
StartNewLineAndIndent; WriteSymbol; ReadSymbol;\r
ChangeMarginTo(SavedLeftMargin);\r
END {DoRecord};\r
\r
\r
PROCEDURE DoVariantRecordPart;\r
\r
VAR\r
SavedLeftMargin,\r
OtherSavedMargin: Margins;\r
\r
BEGIN\r
OtherSavedMargin := ActualLeftMargin;\r
IF DeclarAlignment > 0\r
THEN\r
BEGIN\r
REPEAT WriteSymbol; ReadSymbol;\r
UNTIL SymbolName IN [ColonSymbol, OfSymbol];\r
IF SymbolName = Colonsymbol\r
THEN\r
BEGIN\r
WriteSymbol; ReadSymbol;\r
WITH UnWritten[LastEOL] DO\r
BEGIN\r
IndentAfterEOL := IndentAfterEOL + AlignColumn -\r
WriteColumn;\r
IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0;\r
END;\r
WriteColumn := AlignColumn;\r
ChangeMarginTo(ActualLeftMargin + AlignColumn -\r
WriteColumn);\r
END;\r
END;\r
IF SymbolName <> OfSymbol THEN\r
REPEAT WriteSymbol; ReadSymbol; UNTIL SymbolName = OfSymbol;\r
ChangeMarginTo(ActualLeftMargin + IndentIndex);\r
REPEAT\r
WriteSymbol; ReadSymbol;\r
IF SymbolName <> EndSymbol\r
THEN\r
BEGIN\r
StartNewLineAndIndent;\r
REPEAT WriteSymbol; ReadSymbol;\r
UNTIL SymbolName IN [LeftParenth, Semicolon, EndSymbol];\r
IF SymbolName = LeftParenth\r
THEN\r
BEGIN\r
WriteSymbol; ReadSymbol;\r
SavedLeftMargin := ActualLeftMargin;\r
ChangeMarginTo(WriteColumn - WriteLeftCol);\r
DoFieldListUntil([RightParenth]); WriteSymbol;\r
ReadSymbol; ChangeMarginTo(SavedLeftMargin);\r
END;\r
END;\r
UNTIL SymbolName <> SemiColon;\r
ChangeMarginTo(OtherSavedMargin);\r
END {DoVariantRecordPart};\r
\r
\r
BEGIN {DoFieldListUntil}\r
LastEOL := Oldest;\r
IF LastSymbol= LeftParenth\r
THEN FOR I := 1 TO declarAlignment - Length DO WriteA(' ');\r
AlignColumn := LeftMargin + WriteLeftCol + DeclarAlignment + 1;\r
WHILE NOT (Symbolname IN EndFieldList) DO\r
BEGIN\r
IF LastSymbol IN [SemiColon, Comment] THEN\r
IF SymbolName <> SemiColon\r
THEN BEGIN StartNewLineAndIndent; LastEOL := OLdest END;\r
IF SymbolName IN [RecordSymbol, CaseSymbol, LeftParenth,\r
CommaSymbol, ColonSymbol, EqualSymbol]\r
THEN\r
CASE SymbolName OF\r
RecordSymbol: DoRecord;\r
CaseSymbol: DoVariantRecordPart;\r
LeftParenth: DoParentheses;\r
CommaSymbol, ColonSymbol, EqualSymbol:\r
BEGIN\r
WriteSymbol;\r
IF DeclarAlignment > 0\r
THEN\r
IF NOT (EndLabel <= EndFieldList)\r
THEN\r
BEGIN\r
WITH UnWritten[LastEOL] DO\r
BEGIN\r
IndentAfterEOL := IndentAfterEOL +\r
AlignColumn - WriteColumn;\r
IF IndentAfterEOL < 0\r
THEN IndentAfterEOL := 0;\r
WriteColumn := AlignColumn;\r
END;\r
IF SymbolName = CommaSymbol THEN\r
BEGIN\r
StartNewLineAndIndent; LastEOL := OLdest;\r
END;\r
END {If DeclarAlignment};\r
ReadSymbol;\r
END { , : = }\r
END {Case}\r
ELSE BEGIN WriteSymbol; ReadSymbol END;\r
END {While};\r
END {DoFieldListUntil};\r
\r
\r
BEGIN {DoDeclarationUntil}\r
StartNewLineAndIndent; WriteSymbol;\r
ChangeMarginTo(ActualLeftMargin + IndentIndex);\r
StartNewLineAndIndent; ReadSymbol;\r
DoFieldListUntil(EndDeclaration); StartNewLineAndIndent;\r
ChangeMarginTo(ActualLeftMargin - IndentIndex);\r
END {DoDeclarationUntil};\r
\r
PROCEDURE DoBlock(BlockName: CommentText; BlockNmLength: Width); FORWARD;\r
\r
\r
PROCEDURE DoProcedures;\r
\r
VAR\r
I: 0 .. 20;\r
ProcName: CommentText;\r
ProcNmLength: Width;\r
\r
BEGIN\r
FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;\r
StartNewLineAndIndent; WriteSymbol; ReadSymbol;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, I* AlfaLeng + 1, ProcName[I + 1]);\r
ProcNmLength := Length; WriteSymbol; ReadSymbol;\r
IF SymbolName = LeftParenth THEN\r
BEGIN\r
WriteSymbol;\r
REPEAT ReadSymbol; WriteSymbol;\r
UNTIL SymbolName= RightParenth;\r
ReadSymbol;\r
END;\r
IF SymbolName= ColonSymbol THEN\r
REPEAT WriteSymbol; ReadSymbol; UNTIL SymbolName = SemiColon;\r
WriteSymbol; ReadSymbol;\r
ChangeMarginTo(ActualLeftMArgin + IndentIndex);\r
StartNewLineANdIndent; LastProgPartWasBody := False;\r
DoBlock(ProcName, ProcNmLength); LastProgPartWasBody := True;\r
ChangeMarginTo(ActualLeftMArgin - IndentIndex); WriteSymbol;\r
ReadSymbol; StartNewLineAndIndent;\r
END {DoProcedures};\r
\r
\r
PROCEDURE DoStatement(VAR IfThenBunchNeeded, AtProcBeginning:Boolean;\r
VAR AddedBlanks: Width; StatmtSymbol:\r
CommentText; StmtSymLength: Width);\r
\r
VAR\r
I: Width;\r
StatmtBeginning: LongInt;\r
StatmtPart: ARRAY [1 .. 4] OF LongInt;\r
BlksOnCurrntLine,\r
BlksAddedByThisStmt: Integer;\r
Successful: Boolean;\r
\r
PROCEDURE Bunch(Beginning, BreakPt, Ending: LongInt;\r
StatmtSeperation: OptionSize);\r
BEGIN\r
IF BunchWanted OR IfThenBunchNeeded\r
THEN\r
BEGIN\r
IF StatmtSeparation < 1 THEN StatmtSeparation := 1;\r
BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1;\r
Successful := ((Ending- Beginning + BlksOnCurrntLine +\r
UnWritten[Beginning MOD BufferSize]. IndentAfterEOL) <\r
WriteRightCol) AND (CharCount - Beginning < BufferSize);\r
IF Successful\r
THEN\r
BEGIN\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
StatmtSeparation - 1;\r
Unwritten[Breakpt MOD BufferSize].IndentAfterEOL := -\r
StatmtSeparation;\r
END;\r
END;\r
END {Bunch};\r
\r
\r
PROCEDURE WriteComment;\r
\r
VAR\r
I: Width;\r
SavedLength: Width;\r
SavedSymbolName: Symbols;\r
SavedChars: SymbolString;\r
\r
BEGIN\r
SavedSymbolName := SymbolName;\r
FOR I := 1 TO Length DO SavedChars[I] := Symbol[I];\r
SavedLength := Length; SymbolName := OtherSymbol;\r
Symbol[1] :='('; Symbol[2] := '*'; Length := 2; WriteSymbol;\r
FOR I := 0 TO (StmtSymLength - 1) DIV Alfaleng DO\r
Unpack(StatmtSymbol[I + 1], Symbol, (I * AlfaLeng + 1));\r
Length := StmtSymLength; SymbolName := PeriodSymbol;\r
LastSymbol := PeriodSymbol; WriteSymbol;\r
Symbol[1] :='*'; Symbol[2] := ')'; Length := 2; WriteSymbol;\r
SymbolName := SavedSymbolName; Length := SavedLength;\r
FOR I := 1 TO Length DO Symbol[I] := SavedChars[I];\r
END {WriteComment};\r
\r
\r
PROCEDURE DoStmtList(EndList: Symbols);\r
\r
VAR\r
BlksAfterPrt2: Width;\r
AtProcEnd: Boolean;\r
\r
BEGIN\r
AtProcEnd := AtProcBeginning; WriteSymbol; ReadSymbol;\r
StatmtPart[1] := CharCount + 1; StatmtPart[2] := StatmtPart[1];\r
IF SymbolName <> EndLIst\r
THEN\r
BEGIN\r
IF ProcNamesWanted THEN\r
IF AtProcBeginning THEN\r
IF LastProgPartWasBody\r
THEN IF LastSymbol = BeginSymbol THEN WriteComment;\r
AtProcBeginning := False;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol, StmtSymLength);\r
BlksAfterPrt2 := AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;\r
WHILE SymbolName <> EndList DO\r
BEGIN\r
WriteSymbol; ReadSymbol;\r
IF SymbolName <> EndList\r
THEN\r
BEGIN\r
StatmtPart[3] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol,\r
StmtSymLength);\r
BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2;\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
AddedBlanks;\r
Bunch(StatmtPart[2], StatmtPart[3], CharCount,\r
StatmtSeparation);\r
IF NOT Successful\r
THEN\r
BEGIN\r
BlksAfterPrt2 := AddedBlanks;\r
StatmtPart[2] := StatmtPart[3];\r
END\r
ELSE BlksAfterPrt2 := BlksOnCurrntLine;\r
END;\r
END { While };\r
END { If SymbolName <> EndList };\r
BlksOnCurrntLine := BlksAddedByThisStmt;\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount, SymbolGap);\r
StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
REPEAT WriteSymbol; ReadSymbol;\r
UNTIL SymbolName IN [ SemiColon, UntilSymbol, EndSymbol,\r
EndLoopSymbol, ElseSymbol, PeriodSymbol];\r
IF Successful\r
THEN\r
BEGIN\r
IF EndList = UntilSymbol\r
THEN StatmtPart[4] := StatmtSeparation\r
ELSE StatmtPart[4] := SymbolGap;\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount,\r
StatmtPart[4]);\r
END { If Successful};\r
IF NOT (Successful AND BunchWanted)\r
THEN\r
IF Endlist= EndSymbol THEN\r
IF LastSymbol= EndSymbol THEN\r
IF AtProcEnd AND ProcNamesWanted THEN WriteComment\r
ELSE IF EndCommentsWanted THEN WriteComment;\r
END {DoStmtList};\r
\r
PROCEDURE DoOtherwise;\r
\r
VAR\r
BlksAfterPrt2: Width;\r
BEGIN\r
WriteSymbol; ReadSymbol;\r
StatmtPart[1] := CharCount + 1; StatmtPart[2] := StatmtPart[1];\r
IF SymbolName <> EndSymbol\r
THEN\r
BEGIN\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol, StmtSymLength);\r
BlksAfterPrt2 := AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;\r
WHILE SymbolName <> EndSymbol DO\r
BEGIN\r
WriteSymbol; ReadSymbol;\r
IF SymbolName <> EndSymbol\r
THEN\r
BEGIN\r
StatmtPart[3] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol,\r
StmtSymLength);\r
BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2;\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
AddedBlanks;\r
Bunch(StatmtPart[2], StatmtPart[3], CharCount,\r
StatmtSeparation);\r
IF NOT Successful\r
THEN\r
BEGIN\r
BlksAfterPrt2 := AddedBlanks;\r
StatmtPart[2] := StatmtPart[3];\r
END\r
ELSE BlksAfterPrt2 := BlksOnCurrntLine;\r
END;\r
END { While };\r
END { If SymbolName <> EndSymbol };\r
BlksOnCurrntLine := BlksAddedByThisStmt;\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount, SymbolGap);\r
(* StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
Repeat WriteSymbol; ReadSymbol;\r
Until SymbolName In [ SemiColon, UntilSymbol, EndSymbol,\r
EndLoopSymbol, ElseSymbol, PeriodSymbol];\r
If Successful\r
Then\r
Begin\r
StatmtPart[4] := SymbolGap;\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount,\r
StatmtPart[4]);\r
End { If Successful}; *)\r
END {DoOtherwise};\r
\r
\r
BEGIN {DoStatement}\r
BlksOnCurrntLine := 0; SuccessFul := False;\r
BlksAddedByThisStmt := 0;\r
ChangeMarginTo(ActualLeftMargin + IndentIndex);\r
StartNewLineAndIndent; StatmtBeginning := CharCount;\r
IF SymbolIsNumber\r
THEN\r
BEGIN\r
WITH UnWritten[Oldest] DO\r
BEGIN\r
IndentAfterEOL := IndentAfterEOL - 1 - Length - SymbolGap;\r
IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0;\r
END;\r
WriteSymbol; ReadSymbol {Write Label}; WriteSymbol;\r
ReadSymbol {Write Colon};\r
END;\r
CASE StatementTypeOf[SymbolName] OF\r
ForWithWhileStatement:\r
BEGIN\r
Pack(Symbol, 1, StatmtSymbol[1]);\r
StmtSymLength := Length;\r
REPEAT WriteSymbol; ReadSymbol\r
UNTIL SymbolName = DoSymbol;\r
WriteSymbol; ReadSymbol; StatmtPart[1] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol, StmtSymLength);\r
BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks;\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount, SymbolGap);\r
END;\r
RepeatStatement: DoStmtList(UntilSymbol);\r
LoopStatement: DoStmtList(EndLoopSymbol);\r
IfStatement:\r
BEGIN\r
Pack(Symbol, 1, StatmtSymbol[1]);\r
StmtSymLength := Length;\r
REPEAT WriteSymbol; ReadSymbol\r
UNTIL SymbolName = ThenSymbol;\r
StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
WriteSymbol; ReadSymbol; StatmtPart[2] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol, StmtSymLength);\r
BlksOnCurrntLine := AddedBlanks;\r
BlksAddedByThisStmt := AddedBlanks;\r
Bunch(StatmtPart[1], StatmtPart[2], CharCount, SymbolGap);\r
IF Successful\r
THEN\r
Bunch(StatmtBeginning, StatmtPart[1], CharCount,\r
StatmtSeparation)\r
ELSE IfThenBunchNeeded := True;\r
IF SymbolName = ElseSymbol\r
THEN\r
BEGIN\r
Pack(Symbol, 1, StatmtSymbol[1]);\r
StmtSymLength := Length; IfThenBunchNeeded := False;\r
StartNewLineAndIndent; StatmtPart[3] := CharCount;\r
WriteSymbol; ReadSymbol;\r
StatmtPart[4] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol, StmtSymLength);\r
BlksOnCurrntLine := AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
AddedBlanks;\r
Bunch(StatmtPart[3], StatmtPart[4], CharCount,\r
SymbolGap);\r
BlksOnCurrntLine := BlksAddedByThisStmt;\r
IF Successful THEN\r
Bunch(StatmtBeginning, StatmtPart[3], CharCount,\r
StatmtSeparation);\r
END\r
ELSE\r
IF ( CharCount - StatmtBeginning) < BufferSize\r
THEN\r
BEGIN\r
BunchWanted := NOT BunchWanted;\r
BlksOnCurrntLine := 0;\r
Bunch(StatmtBeginning, StatmtPart[1], StatmtPart[2],\r
SymbolGap);\r
BunchWanted := NOT BunchWanted;\r
END;\r
IfThenBunchNeeded := False;\r
END {Ifstatement};\r
CaseStatement:\r
BEGIN\r
REPEAT WriteSymbol; ReadSymbol\r
UNTIL SymbolName = OfSymbol;\r
WriteSymbol; ReadSymbol;\r
ChangeMarginTo(ActualLeftMargin + IndentIndex);\r
WHILE (SymbolName <> EndSymbol) AND (SymbolName <> ElseSymbol)\r
AND (SymbolName <> OtherwiseSymbol) DO\r
BEGIN\r
StartNewLineAndIndent; { LEI 1988-10-19}\r
StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, (I * Alfaleng + 1), StatmtSymbol[I + 1]);\r
StmtSymLength := Length;\r
REPEAT WriteSymbol; ReadSymbol\r
UNTIL SymbolName = ColonSymbol;\r
WriteSymbol; ReadSymbol;\r
IF NOT (SymbolName IN [SemiColon, EndSymbol])\r
THEN\r
BEGIN\r
StatmtPart[2] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol,\r
StmtsymLength);\r
BlksOnCurrntLine := AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
AddedBlanks;\r
Bunch(StatmtPart[1], statmtPart[2], CharCount,\r
SymbolGap);\r
END {If not};\r
IF SymbolName = SemiColon\r
THEN BEGIN WriteSymbol; ReadSymbol; END;\r
END;\r
IF SymbolName IN [OtherwiseSymbol] THEN\r
BEGIN\r
StartNewLineAndIndent; { LEI 1988-10-19}\r
StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, (I * Alfaleng + 1), StatmtSymbol[I + 1]);\r
StmtSymLength := Length;\r
IF SymbolName = SemiColon\r
THEN BEGIN WriteSymbol; ReadSymbol; END;\r
DoOtherwise;\r
END\r
ELSE IF SymbolName IN [ElseSymbol] THEN\r
BEGIN\r
StartNewLineAndIndent; { LEI 1988-10-19}\r
StartNewLineAndIndent; StatmtPart[1] := CharCount;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, (I * Alfaleng + 1), StatmtSymbol[I + 1]);\r
StmtSymLength := Length;\r
WriteSymbol; ReadSymbol;\r
IF NOT (SymbolName IN [SemiColon, EndSymbol])\r
THEN\r
BEGIN\r
StatmtPart[2] := CharCount + 1;\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,AddedBlanks, StatmtSymbol,\r
StmtsymLength);\r
BlksOnCurrntLine := AddedBlanks;\r
BlksAddedByThisStmt := BlksAddedByThisStmt +\r
AddedBlanks;\r
Bunch(StatmtPart[1], statmtPart[2], CharCount,\r
SymbolGap);\r
END {If not};\r
IF SymbolName = SemiColon\r
THEN BEGIN WriteSymbol; ReadSymbol; END;\r
END;\r
\r
ChangeMarginTo(ActualLeftMargin - IndentIndex);\r
StartNewLineAndIndent; WriteSymbol; ReadSymbol;\r
IF EndCommentsWanted AND (LastSymbol = EndSymbol) THEN\r
BEGIN\r
StatmtSymbol[1] := 'CASE '; StmtSymLength := 4;\r
WriteComment;\r
END;\r
END {CaseStatement};\r
OtherStatement:\r
BEGIN\r
WHILE NOT(SymbolName IN [SemiColon, UntilSymbol, EndSymbol,\r
EndLoopSymbol, ElseSymbol]) DO\r
BEGIN WriteSymbol; ReadSymbol END;\r
END {Other};\r
CompoundStatement: DoStmtLIst(EndSymbol)\r
END {Case};\r
AddedBlanks := BlksAddedByThisStmt;\r
ChangeMarginTo(ActualLeftMargin - IndentIndex);\r
END {DoStatement};\r
\r
PROCEDURE DoBlock;\r
\r
VAR\r
I: Width;\r
IfThenBunchNeeded: Boolean;\r
AtProcBeginning: Boolean;\r
\r
BEGIN {DoBlock}\r
LastProgPartWasBody := LastProgPartWasBody AND (SymbolName =\r
BeginSymbol);\r
REPEAT\r
IF SymbolName = LabelSymbol THEN DodeclarationUntil(EndLabel);\r
IF SymbolName = ConstSymbol THEN DodeclarationUntil(EndConst);\r
IF SymbolName = TypeSymbol THEN DodeclarationUntil(EndType);\r
IF SymbolName = VarSymbol THEN DodeclarationUntil(EndVar);\r
WHILE SymbolName IN [FuncSymbol, ProcSymbol] DO DoProcedures;\r
UNTIL (NOT (FreeDeclaration IN Language)) OR\r
NOT (SymbolName IN [LabelSymbol, ConstSymbol, TypeSymbol,\r
VarSymbol]);\r
IF SymbolName = BeginSymbol\r
THEN\r
BEGIN\r
IF LastProgPartWasBody\r
THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;\r
IfThenBunchNeeded := False; AtProcBeginning := True;\r
ChangeMarginTo(ActualLeftMArgin - IndentIndex);\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,I, BlockName, BlockNmLength) {I is Dummy param };\r
LastProgPartWasBody := true;\r
ChangeMarginTo(ActualLeftMArgin + IndentIndex);\r
END\r
ELSE BEGIN WriteSymbol; ReadSymbol {Write Forward} END\r
END {DoBlock};\r
\r
\r
PROCEDURE DoProcedureDefs\r
{Used to scan definition of procedures and functions in units i. e.\r
without a body };\r
\r
VAR\r
I: 0 .. 20;\r
ProcName: CommentText;\r
ProcNmLength: Width;\r
\r
BEGIN\r
FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;\r
StartNewLineAndIndent; WriteSymbol; ReadSymbol;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, I* AlfaLeng + 1, ProcName[I + 1]);\r
ProcNmLength := Length; WriteSymbol; ReadSymbol;\r
IF SymbolName = LeftParenth THEN\r
BEGIN\r
WriteSymbol;\r
REPEAT ReadSymbol; WriteSymbol;\r
UNTIL SymbolName= RightParenth;\r
ReadSymbol;\r
END;\r
IF SymbolName= ColonSymbol THEN\r
REPEAT WriteSymbol; ReadSymbol; UNTIL SymbolName = SemiColon;\r
WriteSymbol; ReadSymbol;\r
{ ChangeMarginTo(ActualLeftMArgin + IndentIndex);\r
StartNewLineANdIndent; LastProgPartWasBody := False;\r
DoBlock(ProcName, ProcNmLength); LastProgPartWasBody := True;\r
ChangeMarginTo(ActualLeftMArgin - IndentIndex); WriteSymbol;\r
ReadSymbol; StartNewLineAndIndent;\r
}\r
END {DoProcedureDefs};\r
\r
PROCEDURE DoUnit( UnitName: CommentText; UnitNmLength: Width);\r
\r
VAR\r
I: Width;\r
IfThenBunchNeeded: Boolean;\r
AtProcBeginning: Boolean;\r
\r
BEGIN {DoUnit}\r
LastProgPartWasBody := LastProgPartWasBody AND (SymbolName =\r
BeginSymbol);\r
REPEAT\r
IF SymbolName = LabelSymbol THEN DodeclarationUntil(EndLabel+[IMPLEMENTATIONSYMBOL]);\r
IF SymbolName = ConstSymbol THEN DodeclarationUntil(EndConst+[IMPLEMENTATIONSYMBOL]);\r
IF SymbolName = TypeSymbol THEN DodeclarationUntil(EndType+[IMPLEMENTATIONSYMBOL]);\r
IF SymbolName = VarSymbol THEN DodeclarationUntil(EndVar+[IMPLEMENTATIONSYMBOL]);\r
WHILE SymbolName IN [FuncSymbol, ProcSymbol] DO DoProcedureDefs;\r
UNTIL (NOT (FreeDeclaration IN Language)) OR\r
NOT (SymbolName IN [LabelSymbol, ConstSymbol, TypeSymbol,\r
VarSymbol]);\r
StartNewLineAndIndent;\r
WriteSymbol{Implementation I hope }; ReadSymbol;\r
StartNewLineAndIndent;\r
REPEAT\r
IF SymbolName = LabelSymbol THEN DodeclarationUntil(EndLabel+[EndSymbol]);\r
IF SymbolName = ConstSymbol THEN DodeclarationUntil(EndConst+[EndSymbol]);\r
IF SymbolName = TypeSymbol THEN DodeclarationUntil(EndType+[EndSymbol]);\r
IF SymbolName = VarSymbol THEN DodeclarationUntil(EndVar+[EndSymbol]);\r
WHILE SymbolName IN [FuncSymbol, ProcSymbol] DO DoProcedures;\r
UNTIL (NOT (FreeDeclaration IN Language)) OR\r
NOT (SymbolName IN [LabelSymbol, ConstSymbol, TypeSymbol,\r
VarSymbol]);\r
IF SymbolName = BeginSymbol\r
THEN\r
BEGIN\r
IF LastProgPartWasBody\r
THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent;\r
IfThenBunchNeeded := False; AtProcBeginning := True;\r
ChangeMarginTo(ActualLeftMArgin - IndentIndex);\r
DoStatement( IfThenBunchNeeded, AtProcBeginning,I, UnitName, UnitNmLength) {I is Dummy param };\r
LastProgPartWasBody := true;\r
ChangeMarginTo(ActualLeftMArgin + IndentIndex);\r
END\r
ELSE\r
BEGIN WriteSymbol; ReadSymbol {Write END} END\r
END {DoUnit};\r
PROCEDURE GetParameters;\r
CONST\r
MaxParam = 2;\r
MaxOption = 1;\r
\r
CONST\r
ParamList : ARRAY[1..MaxParam] OF ParamRec =\r
((Kind:KnownFile; Defined:FALSE; KeyWord:'I'; NumVal:0; TextVal:''),\r
(Kind:FileType; Defined:FALSE; KeyWord:'O'; NumVal:0; TextVal:''));\r
\r
OptionList : ARRAY[1..MaxOption] OF ParamRec =\r
((Kind:Numeric; Defined:FALSE ;KeyWord:'VERSION'; NumVal:4;TextVal:''));\r
\r
VAR\r
in_name, out_name: STRING;\r
\r
BEGIN (* GetParameters *)\r
\r
IF ( ParamCount >= 1) AND ( ParamStr(1 ) = '?') THEN\r
BEGIN\r
ShowHelp;\r
Halt;\r
END;\r
\r
GetParams(ParamList, MaxParam, OptionList, MaxOption);\r
\r
LanguageName := LanguageTypes( OptionList[1].NumVal - 1);\r
\r
{ If no file parameters are given, we connect\r
Input and Output back to std. DOS in and out. }\r
{ Then it is possible to use the normal redirection "<" and ">". }\r
\r
in_name := ParamList[1].TextVal;\r
out_name := ParamList[2].TextVal;\r
\r
Assign(Input, in_name);\r
SetTextBuf(Input, I_buff);\r
Reset(input);\r
Assign(Output, out_name);\r
SetTextBuf(Output, O_buff);\r
Rewrite(Output);\r
END; (* GetParameters *)\r
\r
PROCEDURE SetupLanguage;\r
BEGIN\r
CASE LanguageName OF\r
StandardPascal:\r
Language := [];\r
RTP:\r
Language := [FreeDeclaration,Loops, Locks, Processes, Pools,\r
OtherwiseInCase, Exports, NestedComments,UnderscoreId];\r
TurboPascal3:\r
Language := [ FreeDeclaration, ElseInCase, NestedComments,\r
ProgramNotNeeded,UnderscoreId];\r
TurboPascal4:\r
Language := [ Units, FreeDeclaration, ElseInCase, NestedComments,\r
ProgramNotNeeded,UnderscoreId];\r
END {case };\r
END {SetupLanguage};\r
\r
\r
PROCEDURE Initialize;\r
\r
VAR\r
I: Width;\r
\r
BEGIN\r
{Constants}\r
Digits := ['0'..'9'];\r
BinaryDigits := ['0'..'1'];\r
OctalDigits := ['0'..'7'];\r
TenDIgits := ['0' ..'9'];\r
HexDigits := ['0'..'9','a'..'f','A'..'F'];\r
LettersAndDigits := [ 'A'..'Z', 'a'..'z'] + Digits;\r
IF UnderscoreId IN Language THEN\r
LettersAndDigits := LettersAndDigits + ['_'];\r
AlphaSymbols := [ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol,\r
TypeSymbol, RecordSymbol, CaseSymbol, IfSymbol, ThenSymbol,\r
ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol,\r
WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol,\r
ProcSymbol, FuncSymbol, LabelSymbol, UnitSymbol, UsesSymbol,\r
LoopSymbol, EndloopSymbol, LockSymbol, LockmessSymbol,\r
ProcessSymbol, PoolSymbol, ExportSymbol, OtherwiseSymbol,\r
AlphaOperator];\r
IF FreeDeclaration IN Language THEN\r
BEGIN\r
EndUses := [Labelsymbol, ConstSymbol, TypeSymbol, VarSymbol,\r
ProcSymbol, FuncSymbol, BeginSymbol];\r
EndLabel := EndUses;\r
EndConst := EndLabel;\r
EndType := EndConst;\r
EndVar := EndType;\r
END\r
ELSE\r
BEGIN\r
EndUses := [Labelsymbol, ConstSymbol, TypeSymbol, VarSymbol,\r
ProcSymbol, FuncSymbol, BeginSymbol];\r
EndLabel := EndUses - [LabelSymbol];\r
EndConst := EndLabel - [ConstSymbol];\r
EndType := EndConst - [TypeSymbol];\r
EndVar := EndType - [VarSymbol];\r
END;\r
\r
{Initialize Column data}\r
WriteColumn := 0; LeftMargin := 0; ActualLeftMargin := 0;\r
OutputCol := 1; ReadLeftCol := 1; ReadRightCol := MaxReadRightCol;\r
WriteLeftCol := 1; WriteRightCol := MaxWriteRightCOl; Oldest :=1;\r
CharCount := 1; LineNumber := 0; Increment := 0;\r
\r
{Initialize Boolean Parameters}\r
PackerIsOff := True; BunchWanted := False; DisplayIsOn := True;\r
ProcNamesWanted := true; EndCommentsWanted := true;\r
Noformatting := false;\r
\r
{Initialize Numeric parameters }\r
IndentIndex := 3; LongLineIndent := 3; Procseparation := 2;\r
SymbolGap := 1; StatmtSeparation := 3; DeclarAlignment := 0;\r
\r
{Initialize Input Context data: }\r
ReadColumn := 1; ChIsEOL := False; NextChIsEOL := False;\r
FOR I := 0 TO BufferSize DO Symbol[I] := ' ';\r
LastSymbol := PeriodSymbol; LastProgPartWasBody := False;\r
\r
{Special Turbo Pascal:}\r
InputPtr := ' ';\r
END {Initialize};\r
\r
\r
BEGIN {MainProgram}\r
GetParameters;\r
SetupLanguage;\r
ConstantsInitialization; Initialize;\r
IF Eof(Input) THEN WriteLn(' *** No Program found to format.')\r
ELSE\r
BEGIN\r
ReadAcharacter; Readsymbol;\r
StartSymbol := SymbolName;\r
IF NOT (SymbolName IN [ ProgSymbol, UnitSymbol, ProcessSymbol])\r
THEN\r
IF (SymbolName IN ([LabelSymbol]+EndLabel) ) AND\r
(ProgramNotNeeded IN Language)\r
THEN\r
BEGIN\r
Main[0 + 1] := 'MAIN ';\r
MainNmLength := 4;\r
DoBlock(Main, MainNmLength);\r
WriteA('.');\r
FlushUnwrittenBuffer;\r
END\r
ELSE WriteLn(' *** "Program" expected.')\r
ELSE\r
BEGIN\r
ProgramText := SymbolName <> UnitSymbol;\r
StartNewLineAndIndent;\r
WriteSymbol;\r
ReadSymbol;\r
FOR I := 0 TO (Length - 1) DIV AlfaLeng DO\r
Pack(Symbol, (I * AlfaLeng + 1), Main[I + 1]);\r
MainNmLength := Length;\r
IF StartSymbol = ProcessSymbol THEN\r
BEGIN\r
WriteSymbol;\r
ReadSymbol;\r
IF SymbolName = LeftParenth THEN\r
DoDeclarationUntil([RightParenth]);\r
WriteSymbol;\r
ReadSymbol;\r
END\r
ELSE\r
REPEAT WriteSymbol; ReadSymbol; UNTIL SymbolName = SemiColon;\r
WriteSymbol; ReadSymbol; StartNewLineAndIndent;\r
IF NOT ProgramText THEN\r
BEGIN\r
{ Read INTERFACE }\r
WriteSymbol; ReadSymbol; StartNewLineAndIndent;\r
END;\r
IF SymbolName = UsesSymbol THEN\r
DoDeclarationUntil(EndUses);\r
IF ProgramText THEN\r
DoBlock(Main, MainNmLength)\r
ELSE\r
DoUnit(Main, MainNmLength);\r
WriteA('.');\r
FlushUnwrittenBuffer;\r
END;\r
END;\r
END {MainProgram}.\r