home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
utility
/
rtfgen.zip
/
RTFGEN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-02-23
|
18KB
|
803 lines
{ RTFGEN }
(********* Source code (C) Copyright 1992, by L. David Baldwin *********)
(********* All Rights Reserved *********)
{$A+,B-,E-,F-,G-,I+,N-,O-,R-,S-,V-,X-}
{$M 16384,0,0}
PROGRAM RTFGEN;
Uses Crt{, MySubs};
Const
TwipsPerSpace = 120;
DefaultFont : String[6] = '2';
DefaultFontSize : String[10] = '20';
ParaChar : Char = '`';
Tokenleng = 28; {Max symbol length}
Tab = #9;
MaxRes = 13;
Type
Symb = (
OtherChar, Comma, Colon, SemiColon, Lbrack, Rbrack, Dot, Slash,
LLbrack, RRbrack, OtherPunct, Ident, EolSy, Space, ParaSy, TabSy,
BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy,
TopicStart, TopicEnd, DocStartSy, DocEndSy, CommandSy, BMCSy, BMLSy,
BMRSy, FontCommand, Number, BlockStartSy, BlockEndSy);
SymString = string[14];
Var
Sy, SaveSy : Symb;
Const
ResWord : array[1..MaxRes] of SymString = (
'\buildtag', '\topic', '\title', '\keyword', '\browse', '\bmc', '\bml',
'\bmr', '\docstart', '\docend', '\tab', '\blockstart', '\blockend');
ResSy : array[1..MaxRes] of Symb = (
BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy, BMCSy, BMLSy,
BMRSy, DocStartSy, DocEndSy, TabSy, BlockStartSy, BlockEndSy);
Type
TokenString = string[Tokenleng];
String127 = string[127];
Filestring = string[64];
PairType = array[0..1] of Char;
Var
BrackCount, LineNo, Chi, ErrCount : Integer;
Pair : Word;
Spair : PairType absolute Pair;
LCh : Char absolute Pair;
UCh : Char;
St : String127;
ErrFlag, EofInf, InInclude, InTopic : Boolean;
SourceName : Filestring;
Inf, Outf : Text;
InBuff, OutBuff : array[1..1000] of Char;
Value : LongInt;
LCToken : TokenString;
OutString, GlobalHeader, TopicHeader : String;
BlockHeader : array[1..4] of String;
BIndex : Integer;
{-------------Error}
PROCEDURE Error(II :Integer; S :String127);
Var X,Y : Integer;
NewS : String127;
begin
GotoXY(1,WhereY);
WriteLn(St);
Y:=WhereY;
X:=II-3; if X<1 then X:=1;
GotoXY(X, Y);
Write('^');
Str(LineNo, NewS);
NewS := NewS + ' Error';
if S[0]>#0 then NewS:=NewS + ', '+S;
if X+Ord(NewS[0])>80 then X:=X-Ord(NewS[0]) else X:=X+1;
GotoXY(X,Y); WriteLn(NewS);
ErrCount:=Succ(ErrCount);
if ErrCount>6 then
begin
WriteLn('Excessive Number of Errors');
Halt(1);
end;
ErrFlag := True;
end;
{-------------Positn}
function Positn(Pat, Src : String; I : Integer) : Integer;
{find the position of a substring in a string starting at the Ith char}
var
N : Integer;
begin
if I < 1 then I := 1;
Delete(Src, 1, I-1);
N := Pos(Pat, Src);
if N = 0 then Positn := 0
else Positn := N+I-1;
end;
{-------------OutFile}
PROCEDURE OutFile(S : String);
var
WriteIt : boolean;
Leng, I : Integer;
begin
{a hard to find bug is mismatched braces. Keep count of these so
can keep track of matching.}
I := 0;
repeat
I := Positn('{', S, I+1);
if (I > 0) then
if not ((I > 1) and (S[I-1] = '\')) then Inc(BrackCount);
until I = 0;
repeat
I := Positn('}', S, I+1);
if (I > 0) then
if not ((I > 1) and (S[I-1] = '\')) then Dec(BrackCount);
until I = 0;
{try to avoid hanging spaces on end of lines as editors delete them}
Leng := Length(OutString)+Length(S);
WriteIt := (Leng >= 75) and (OutString[Length(OutString)] <> ' ')
or (Leng >= 200);
if WriteIt then
begin
WriteLn(Outf, OutString);
OutString := S;
end
else OutString := OutString+S;
end;
{-------------Flush}
PROCEDURE Flush;
begin
if Length(OutString) > 0 then
begin WriteLn(OutF, OutString); OutString := ''; end;
end;
{-------------GetCh}
PROCEDURE GetCh;
{Return next char in Uch and Lch with Uch in upper case. Ignore comments}
Var Comment : Boolean;
PROCEDURE GetchBasic; {read a character and a character pair}
begin
if Chi<=Ord(St[0]) then
begin {NOTE: pair has the same address as lch}
Pair := MemW[DSeg : Ofs(St[Chi])];
if (LCh=Tab) and not InTopic then LCh:=' ';
UCh := UpCase(LCh);
Chi := Chi+1;
end
else
if not EOF(Inf) then
begin
ReadLn(Inf,St);
Inc(LineNo);
St:=St+^M; {Add EOL}
Chi:=1;
GetCh;
end
else
begin
EofInf:=True;
if Comment then
begin
WriteLn('Open Comment at End of Input File');
Halt(1);
end;
end;
end;
begin {Getch}
repeat
if EofInf then
begin WriteLn('Unexpected End of Input File'); Halt(1) end;
Comment:=False;
GetchBasic;
if (SPair='(*') then
begin
Comment:=True;
repeat GetchBasic; until SPair='*)';
GetchBasic; {pass by the '*'}
end;
until not Comment;
end;
{-----------IsPair}
FUNCTION IsPair : Boolean;
Const
Limit = 8;
PA : array[1..Limit] of PairType = (
'[[', ']]', '\[', '\]', '\\', '\`',
'\{', '\}'); {!! <- if '`' made optional, change!!}
Var
I : Integer;
Was : Pairtype;
begin
IsPair := False;
for I := 1 to Limit do
if PA[I] = Spair then
begin
Was := SPair;
Sy := OtherPunct;
IsPair := True;
GetCh;
case I of
5,7,8 : LCToken := Was;
1 : Sy := LLbrack;
2 : Sy := RRbrack;
else LCToken := LCh;
end;
GetCh;
Exit;
end;
end;
{-------------GetNumber}
FUNCTION GetNumber : Boolean; {Pick up a Number}
Var
Done : Boolean;
Code : Integer;
begin
case UCh of
'0'..'9' : LCToken := '';
else
begin
GetNumber := False;
Exit;
end;
end;
GetNumber := True;
Sy := Number;
Done := False;
if not EofInf then
while not Done do
case UCh of
'0'..'9' :
begin
LCToken := LCToken+UCh;
GetCh;
end;
else Done := True;
end;
Val(LCToken, Value, Code);
end;
{-------------GetCommand}
FUNCTION GetCommand : Boolean; {Pick up a Command}
Label 2;
const
MaxFC = 10;
FontCommands : array[1..MaxFC] of string[6] =
('f', 'fs', 'b', 'i', 'strike', 'ul', 'ulw', 'uld', 'uldb',
'plain');
Var
Done : Boolean;
I : Integer;
AlphaOnly : TokenString;
begin
GetCommand := False;
if UCh <> '\' then Exit;
GetCommand := True;
Sy := CommandSy;
LCToken := LCh;
AlphaOnly := '';
GetCh;
Done := False;
if not EofInf then
begin
while not Done do
case LCh of
'a'..'z' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
Inc(AlphaOnly[0]);
AlphaOnly[Length(AlphaOnly)] := LCh;
end;
GetCh;
end;
else Done := True;
end;
if LCh = '-' then
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
GetCh;
end;
Done := False;
while not Done do
case LCh of
'0'..'9' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
GetCh;
end;
else Done := True;
end;
end;
for I := 1 to MaxRes do
if LCToken = ResWord[I] then
begin
Sy := ResSy[I];
GOTO 2;
end;
if not InTopic then
for I := 1 to MaxFC do
if AlphaOnly = FontCommands[I] then
begin
Sy := FontCommand;
GoTo 2;
end;
2 : {account for possible space after command}
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := ' ';
end;
if UCh = ' ' then GetCh; {use up a space}
end;
{-------------GetIdent}
FUNCTION GetIdent : Boolean; {Pick up a Symbol}
Var
Done : Boolean;
I : Integer;
begin
GetIdent := False;
case UCh of
'A'..'Z', '_' : ;
else
Exit;
end;
GetIdent := True;
Sy := Ident;
LCToken := LCh;
GetCh;
Done := False;
if not EofInf then
while not Done do
case UCh of
'A'..'Z', '0'..'9', '_' :
begin
if Length(LCToken)<Tokenleng then
begin
Inc(LCToken[0]);
LCToken[Length(LCToken)] := LCh;
end;
GetCh;
end;
else Done := True;
end;
end;
{-------------GetTopicEnd}
FUNCTION GetTopicEnd : boolean;
begin
GetTopicEnd := False;
if UCh <> '-' then Exit;
if Pos('----', St) <> 1 then Exit;
Chi := Length(St)+1; {ignore remainder of St}
if not EofInf then
GetCh;
GetTopicEnd := True;
if not InTopic then Error(Chi, '----- when not within topic');
Sy := TopicEnd;
end;
{-------------GetTopicStart}
FUNCTION GetTopicStart : boolean;
begin
GetTopicStart := False;
if UCh <> '=' then Exit;
if Pos('====', St) <> 1 then Exit;
Chi := Length(St)+1; {ignore remainder of St}
if not EofInf then
GetCh;
GetTopicStart := True;
if InTopic then Error(Chi, '==== when already within topic');
Sy := TopicStart;
end;
{-----------Punctuation}
FUNCTION Punctuation : Boolean;
{-Check to see if Uch is a punctuation mark; if so, store the
punctuation type in Sy}
Var
I : Integer;
Const
Punct : string[10] = ^M^I' :;[].';
SyArray : array[1..8] of Symb = (
EOLSy, TabSy, Space, Colon, SemiColon, Lbrack, Rbrack, Dot);
begin
Punctuation := False;
I := Pos(UCh, Punct);
case I of
1..8 :
Sy := SyArray[I];
else if UCH = ParaChar then
Sy := ParaSy
else Exit;
end;
Punctuation := True;
case Sy of
EOLSy : LCToken := ' ';
ParaSy : LCToken := '';
TabSy : LCToken := '\tab ';
else LCToken := LCh;
end;
GetCh;
end;
{-----------Next}
PROCEDURE Next;
{-Get the next token on the command line}
begin {Next}
if EofInf then
begin
WriteLn('Unexpected end of input file');
Close(Outf);
Close(Inf);
Halt(1);
end;
if IsPair then
else if GetCommand then
else if GetIdent then
else if GetNumber then
else if GetTopicEnd then
else if GetTopicStart then
else if Punctuation then
else
begin
Sy := OtherChar;
LCToken := LCh;
if not EOFinf then GetCh;
end;
end; {Next}
{-------------SkipWhiteSpace}
procedure SkipWhiteSpace;
begin
while (UCh = ' ') or (UCh = Tab) do
GetCh;
end;
{-------------ParagraphText}
PROCEDURE ParagraphText;
procedure DoBitmap;
var
S : String[30];
Count : Integer;
const
FileChars : set of char = ['A'..'Z', 'a'..'z', '0'..'9', '!', '#'..'''',
'@', '^'..'`', '~'];
begin
OutFile('\{');
case Sy of
BMCSy : S := 'bmc ';
BMRSy : S := 'bmr ';
BMLSy : S := 'bml ';
end;
SkipWhiteSpace;
Count := 0;
while LCH in FileChars do
begin
S := S+LCh;
GetCh;
Inc(Count);
end;
if (Count > 8) or (Count = 0) then Error(Chi, 'Filename Exp');
if LCh = '.' then
begin
S := S+LCh;
GetCh;
Count := 0;
while LCH in FileChars do
begin
S := S+LCh;
GetCh;
Inc(Count);
end;
if (Count > 3) then Error(Chi, 'Filename Exp');
end;
Next;
OutFile(S+'\}');
end;
procedure CrossRef;
var
SyWas : Symb;
begin
SyWas := Sy;
if Sy = LBrack then
OutFile('{\uldb ')
else OutFile('{\ul ');
SkipWhiteSpace;
Next;
case Sy of
BMCSy, BMLSy, BMRSy :
begin
DoBitmap;
while Sy = Space do Next;
end;
else
begin
While (Sy <> Colon) and (Sy <> EOLSy) do
begin
OutFile(LCToken);
Next;
end;
end;
end;
OutFile('}');
if Sy <> Colon then Error(Chi, 'Colon Exp');
Next; {use up colon}
while Sy = Space do Next;
if (Sy <> Ident) and (Sy <> Dot) and (Sy <> Number) then
Error(Chi, 'Syntax Error in cross reference');
OutFile('{\v ');
repeat
OutFile(LCToken);
Next;
until (Sy <> Ident) and (Sy <> Dot) and (Sy <> Number);
OutFile('}');
while Sy = Space do Next;
if SyWas = LBrack then
begin
if Sy <> RBrack then Error(Chi, '] Exp');
end
else if Sy <> RRbrack then Error(Chi, ']] Exp');
end;
begin
while (Sy <> ParaSy) and (Sy <> TopicEnd) and (Sy <> BlockStartSy)
and (Sy <> BlockEndSy) do
begin
case Sy of
EOLSy :
begin
OutFile(' ');
SkipWhiteSpace;
end;
LBrack, LLbrack : CrossRef;
BMCSy, BMLSy, BMRSy : DoBitmap;
else OutFile(LCToken);
end;
Next;
end;
if Sy = ParaSy then
begin
repeat
Next; {skip trailing stuff, mainly spaces}
until Sy = EOLSy;
Next;
end;
end;
{-------------Paragraph}
procedure Paragraph;
var
Count : Integer;
S : String[10];
begin
repeat {repeat ignores blank lines with spaces}
while Sy = EOLSy do
begin
OutFile('\par');
Next;
end;
Count := 0;
while (Sy = Space) or (Sy = TabSy) do
begin
if Sy = TabSy then
Count := ((Count div 5) +1) * 5 + 1
else Inc(Count);
Next;
end;
until Sy <> EOLSy;
if (Sy <> TopicEnd) and (Sy <> BlockStartSy) and (Sy <> BlockEndSy) then
begin
if Count > 0 then
begin
Str(Count * TwipsPerSpace:-1, S);
OutFile('\li'+S);
end;
{at start of each paragraph, output the paragraph commands entered in
the headers}
if BIndex > 0 then
OutFile('{'+BlockHeader[BIndex])
else
OutFile('{'+GlobalHeader+TopicHeader);
ParagraphText; {do all the text}
OutFile('}\par\pard');
Flush;
end;
end;
{-------------DoTopic}
procedure DoTopic;
begin
OutFile('#{\footnote \pard\plain \sl240 \fs20 # ');
SkipWhiteSpace;
Next;
while (Sy = Ident) or (Sy = Dot) or (Sy = Number) do
begin
OutFile(LCToken);
Next;
end;
if Sy <> ParaSy then Error(Chi, 'Paragraph mark Exp')
else Next;
OutFile('}');
Flush;
end;
{-------------DoBrowse}
procedure DoBrowse;
var
Err : boolean;
begin
OutFile('+{\footnote \pard\plain \sl240 \fs20 + ');
SkipWhiteSpace;
Next;
repeat {Browse symbol can contain many things up to ':' }
case Sy of
OtherChar, Comma, SemiColon, Lbrack, Rbrack, Dot, Slash,
OtherPunct, Ident, Space, TabSy, Number : Err := False;
else Err := True;
end;
if Err then Error(Chi, 'Syntax error in \Browse');
OutFile(LCToken);
Next;
until (Sy = Colon) or (Sy = ParaSy) or (Sy = EOLsy);
if Sy = Colon then
begin
SkipWhiteSpace;
Next;
if Sy <> Number then Error(Chi, 'Number Exp in Browse');
OutFile(':'+LCToken);
SkipWhiteSpace;
Next;
end
else Error(Chi, 'Colon Exp');
if Sy <> ParaSy then Error(Chi, 'Paragraph mark Exp');
OutFile('}');
Flush;
Next;
end;
{-------------DoKeyWord}
procedure DoKeyWord;
var
Err : boolean;
Ch : Char;
S : String[10];
begin
Case Sy of
KeyWordSy : Ch := 'K';
TitleSy : Ch := '$';
BuildTagSy : Ch := '*';
end;
S := LCToken; {save for possible error msg}
OutFile(Ch+'{\footnote \pard\plain \sl240 \fs20 '+Ch+' ');
SkipWhiteSpace;
Next;
repeat {symbols can contain many things }
case Sy of
OtherChar, Comma, Colon, SemiColon, Lbrack, Rbrack, Dot, Slash,
OtherPunct, Ident, Space, TabSy, Number : Err := False;
else Err := True;
end;
if Err then Error(Chi, 'Syntax error in '+S);
OutFile(LCToken);
Next;
until (Sy = ParaSy) or (Sy = EOLSy);
if Sy <> ParaSy then Error(Chi, 'Paragraph mark exp');
OutFile('}');
Flush;
Next;
end;
{-------------DoPage}
PROCEDURE DoPage;
begin
InTopic := True;
Next;
while Sy <> TopicEnd do
if Sy = BlockStartSy then
begin
if BIndex >= 4 then Error(Chi, 'Too many nested blocks')
else Inc(BIndex);
BlockHeader[BIndex] := '';
Next;
while (Sy <> ParaSy) and (Sy <> EOLSy) do
begin
if Sy = CommandSy then
BlockHeader[BIndex] := BlockHeader[BIndex]+LCToken
else if Sy <> Space then Error(Chi, 'Command Expected');
Next;
end;
if Sy = ParaSy then Next;
if Sy = EOLSy then Next;
end
else if Sy = BlockEndSy then
begin
if BIndex < 1 then Error(Chi, 'Unmatched \blockend')
else Dec(BIndex);
while Sy <> EOLSy do Next; {\BlockEnd should be on its own line}
Next;
end
else
Paragraph;
if not EofInf then Next;
OutFile('}\page'); Flush;
if BIndex <> 0 then
begin
Error(Chi, 'Unmatched \blockstart in previous topic');
BIndex := 0;
end;
InTopic := False;
if BrackCount <> 0 then
begin
Error(Chi, '{..} imbalance in last topic');
BrackCount := 0;
end;
end;
{-------------DoDocument}
PROCEDURE DoDocument;
begin
Flush;
Next;
if Sy <> DocEndSy then OutFile('{');
While Sy <> DocEndSy do
case Sy of
TopicSy : DoTopic;
KeyWordSy, BuildTagSy, TitleSy :
DoKeyWord;
BrowseSy : DoBrowse;
TopicStart :
begin
DoPage;
TopicHeader := ''; {get ready for a new topic header string}
while (Sy = EOLSy) or (Sy = space) or (Sy = TabSy) do Next;
if Sy <> DocEndSy then Outfile('{');
end;
EolSy : Next;
CommandSy :
begin
TopicHeader := TopicHeader+LCToken; {add in commands}
Next;
end;
FontCommand :
begin
OutFile(LCToken);
Next;
end;
else Next; {ignore other junk}
end;
Flush;
OutFile('}');
end;
{$I COMMAND.INC}
{-------------MAIN}
begin
ErrCount := 0; LineNo := 0; BIndex := 0; BrackCount := 0;
OutString := '';
GlobalHeader := '';
TopicHeader := '';
if ParamCount >= 1 then CommandInput else PromptForInput;
ReadHeader;
EofInf := False; InTopic := False; ErrFlag := False;
InInclude := False;
OutFile('\f'+DefaultFont+'\fs'+DefaultFontSize);
St[0] := #0; Chi := 1; {get the reading started}
GetCh;
Next;
while not EofInf and (Sy <> DocStartSy) do
begin
if Sy = CommandSy then
GlobalHeader := GlobalHeader+LCToken
else if Sy = FontCommand then
OutFile(LCToken); {else ignore}
Next;
end;
if Sy = DocStartSy then DoDocument;
Flush;
Close(Inf);
Close(Outf);
if ErrFlag then Halt(1);
end.