Black Box 4/BlackBox.cdr/w3_syst/rtfgen.arj/RTFGEN.PAS

Pascal/Delphi Source File | 1992-02-23 | 17.8 KB | 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.