freepascal.compiler/utils/data2inc.pp

{
    $Id$
    Copyright (c) 1999 by Peter Vreman (msg2inc) and
                          Marco van de Voort (data2inc)
    Placed under LGPL (See the file COPYING.FPC, included in this
    distribution, for details about the copyright)

    E-Mail Marco : [email protected]
    Homepage Marco: www.stack.nl/~marcov/xtdlib.htm

    Data2Inc is a heavily modified version of msg2inc.pp which compiles the
     inputfile to include files containing array of char( or byte) typed
     constants.

     (e.g. CONST xxx : ARRAY[0..xxx] OF CHAR =( aa,bb,cc,dd,ee); ,
     or the same but ARRAY OF BYTE )

    Two types of input file are allowed:

    1 A special kind of textfile. Records start with '!'name and all following
       non empty and non comment (starting with '#',':' or '%') lines until
       the next line starting with '!' or EOF are the data. Data are either
       plain text (with \xxx ordinal constants) lines or a kinbd of
       Basic DATA command (these lines start with DATA).
       See demo.txt included with this package for a commented example.

    2  (special parameter -b)
       An arbitrary binary file can get converted to constants. In this mode
        only one constant per include file is possible.

This program has been working for three weeks now, all major bugs are fixed I
hope. A different kind of (possible) problems are the amounts of memory
allocated for the temporary buffer (MaxBuffersize variable), which
is now initialised to 256000 bytes (for textfile type, per record), and 1 MB
maximum for binary files. Also the program has to be compiled with a large
enough heap (-CH parameter of FPC) to allow this. This is the case without
modifying the default ppc386.cfg or adding -Ch parameters.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
program data2inc;
uses strings;

CONST
  version='0.99.13';

{                              ************

                Simple service routines. These are copied from EPasStr.
                The program doesn't use EPasStr, because I want it to function
        BEFORE EPasStr is compiled, and distributable without XTDFPC.}

TYPE CHARSET=SET OF CHAR;

FUNCTION NextCharPos(CONST S : String;C:CHAR;Count:LONGINT):LONGINT;

VAR I,J:LONGINT;

BEGIN
 I:=ORD(S[0]);
 IF I=0 THEN
  J:=0
 ELSE
  BEGIN
   J:=Count;
  IF J>I THEN
   BEGIN
    NextCharPos:=0;
    EXIT
   END;
  WHILE (S[J]<>C) AND (J<=I) DO INC(J);
   IF (J>I) THEN
    J:=0;
  END;
 NextCharPos:=J;
END;

FUNCTION NextCharPosSet(CONST S : String;CONST C:CHARSET;Count:LONGINT):LONGINT;

VAR I,J:LONGINT;

BEGIN
   I:=Length(S);
   IF I=0 THEN
    J:=0
   ELSE
    BEGIN
   J:=Count;
   IF J>I THEN
    BEGIN
     NextCharPosSet:=0;
     EXIT;
    END;
   WHILE (j<=i) AND (NOT (S[J] IN C)) DO INC(J);
   IF (J>I) THEN
    J:=0;                                        // NOT found.
   END;
 NextCharPosSet:=J;
END;


PROCEDURE RTrim(VAR P : String;Ch:Char);

VAR I,J : LONGINT;

BEGIN
 I:=ORD(P[0]);      { Keeping length in local data eases optimalisations}
 IF (I>0) THEN
  BEGIN
   J:=I;
   WHILE (P[J]=Ch) AND (J>0) DO DEC(J);
   IF J<>I THEN
    Delete(P,J+1,I-J+1);
   END;
END;

PROCEDURE UpperCase(VAR S : String);

VAR L,I : LONGINT;

BEGIN
 L:=Length(S);
 IF L>0 THEN
  FOR I:=1 TO L DO
   IF (S[I]>CHR(96)) AND (S[I]<CHR(123)) THEN
    S[I]:=CHR(ORD(S[I])-32);
END;

PROCEDURE LTrim(VAR P : String;Ch:Char);

VAR I,J : LONGINT;

BEGIN
 I:=ORD(P[0]);      { Keeping length in local data eases optimalisations}
 IF (I>0) THEN
  BEGIN
   J:=1;
   WHILE (P[J]=Ch) AND (J<=I) DO INC(J);
   IF J>1 THEN
    Delete(P,1,J-1);
   END;
END;


{---- End EPasStr routines ----}

FUNCTION XlatString(Var S : String):BOOLEAN;
{replaces \xxx in string S with #x, and \\ with \ (escaped)
 which can reduce size of string.

Returns false when an error in the line exists}


Function GetNumber(Position:LONGINT):LONGINT;

VAR C,
    Value,
    I : LONGINT;

BEGIN
 I:=0; Value:=0;
 WHILE I<3 DO
  BEGIN
   C:=ORD(S[Position+I]);
   IF (C>47) AND (C<56) THEN
    C:=C-48
   ELSE
    BEGIN
     GetNumber:=-1;
     EXIT;
    END;
   IF I=0 THEN
    C:=C SHL 6;
   IF I=1 THEN
    C:=C SHL 3;
   Value:=Value + C;
   INC(I);
   END;
 GetNumber:=Value;
END;

VAR S2:String;
    A,B : LONGINT;
    Value : LONGINT;

BEGIN
 A:=1; B:=1;
 WHILE A<=Length(S) DO
  BEGIN
   IF S[A]='\' THEN
    IF S[A+1]='\' THEN
     BEGIN
      S2[B]:='\';
      INC (A,2); INC(B);
     END
    ELSE
     BEGIN
      Value:=GetNumber(A+1);
      IF Value=-1 THEN
       BEGIN
        XlatString:=FALSE;
        EXIT;
       END;
      S2[B]:=CHR(Value);
      INC(B); INC(A,4);
     END
   ELSE
    BEGIN
     S2[B]:=S[A];
     INC (A);
     INC (B);
    END;
  END;
 S2[0]:=CHR(B-1);
 S:=S2;
 XlatString:=TRUE;
END;

{Global equates}

VAR
  Inname,                  {Name of input file}
  OutName,                {Name of output (.inc) file}
  BinConstName: string;     {(-b only) commandline name of constant}
  ArrayByte,            {TRUE when output of ARRAY OF BYTE is desired
                                ARRAY OF CHAR otherwise}
  I_Binary  : BOOLEAN;      {TRUE is binary input, FALSE textual}
  MsgTxt     : pchar;       {Temporary storage of data}
  msgsize    : longint;     {Bytes used in MsgTxt}
  maxbufsize : LONGINT;     {Bytes allocated for MsgTxt}
  C       : CHAR;


{Dump the contents of MsgTxt (msgsize bytes) to file T (which has been opened),
using CONSTNAME as the name of the ARRAY OF CHAR constant}
procedure WriteCharFile(var t:text;constname:string);

  function createconst(b:byte):string;
  {decides whether to use the #xxx code or 'c' style for each char}
  begin
    if (b in [32..127]) and (b<>39) then
     createconst:=''''+chr(b)+''''
    else
     createconst:='#'+chr(b div 100+48)+chr((b mod 100) div 10+48)+chr(b mod 10+48)
  end;

var
  cidx,i  : longint;
  p       : PCHAR;
begin
  Writeln('Writing constant: ',constname,' to file '#39,outname,#39);
{Open textfile}
  write(t,'const ',constname,' : array[0..'); Writeln(t,msgsize-1,'] of char=(');
  p:=msgtxt;
  cidx:=0;
  for i:=0 to msgsize-1 do
   begin
     if cidx=15 then
      begin
        if cidx>0 then
         writeln(t,',')
        else
         writeln(t,'');
        write(t,'  ');
        cidx:=0;
      end
     else
       IF cidx>0 THEN
        write(t,',')
       ELSE
        Write(T,'  ');
     write(t,createconst(ord(p^)));
     inc(cidx);
     inc(p);
   end;
  writeln(t,');');
  Writeln(T);
end;

{Dump the contents of MsgTxt (msgsize bytes) to file T (which has been opened),
using CONSTNAME as the name of the ARRAY OF BYTE constant}
procedure WriteByteFile(var t:text;constname:string);

  function createconst(b:byte):string;
  {Translates byte B to a $xx hex constant}
  VAR l : Byte;
  begin
   createconst[1]:='$'; createconst[0]:=#3;
   l:=ORD(B SHR 4) +48;
   IF l>57 THEN
    l:=L+7;
   createconst[2]:=CHR(l);
   l:=ORD(B and 15) +48;
   IF l>57 THEN
    INC(L,7);
   createconst[3]:=CHR(l);
  end;

var
  cidx,i  : longint;
  p       : pchar;

begin
  Writeln('Writing constant: ',constname,' to file '#39,outname,#39);
{Open textfile}
  write(t,'const ',constname,' : array[0..'); Writeln(t,msgsize-1,'] of byte=(');
  p:=msgtxt;
  cidx:=0;
  for i:=0 to msgsize-1 do
   begin
     if cidx=15 then
      begin
        if cidx>0 then
         writeln(t,',')
        else
         writeln(t,'');
        write(t,'  ');
        cidx:=0;
      end
     else
       IF cidx>0 THEN
        write(t,',')
       ELSE
        Write(T,'  ');
     write(t,createconst(ord(p^)));
     inc(cidx);
     inc(p);
   end;
  writeln(t,');');
  Writeln(T);
end;

FUNCTION SpecialItem(S : String):LONGINT;
{ This procedure finds the next comma, (or the end of the string)
    but comma's within single or double quotes should be ignored.
    Single quotes within double quotes and vice versa are also ignored.}

VAR DataItem : LONGINT;

CONST xFcl : CHARSET = [',',#39,'"'];

BEGIN

    DataItem:=0;
    REPEAT
     DataItem:=NextCharPosSet(S,xFcl,DataItem+1);   {Find first " ' or ,}
      IF (DataItem<>0) AND ((S[DataItem]='"') OR (S[DataItem]=#39)) THEN { (double)Quote found?}
       DataItem:=NextCharPos(S,S[DataItem],DataItem+1);  { then find other one}
     UNTIL (DataItem=0) OR (S[DataItem]=',');
     IF DataItem=0 THEN     {Last data field of this line?}
      DataItem:=Length(S);
    SpecialItem:=DataItem;
END;

{ Handles reading and processing of a textual file}
procedure DoFile;
var
  Infile,
  Outfile : text;       {in and output textfiles}
  line, DataItem,       {line number, position in DATA line}
  I1,I2,                {4 temporary counters}
  I3,I4  : longint;
  s,S1    : string;     {S is string after reading, S1 is temporary string or
                          current DATA-item being processed }
  VarName : String;     { Variable name of constant to be written}

PROCEDURE ParseError;
{Extremely simple errorhandler}

BEGIN
 Writeln('Error in line : ',Line, ' Somewhere near :',#39,S1,#39);
 Close(InfIle); Close(Outfile);
 HALT;
END;

PROCEDURE FixDec;
{ Reads decimal value starting at S1[1].
     Value in I3, number of digits found in I1}

BEGIN
 I1:=1;
 WHILE ((S1[I1]>#47) AND (S1[I1]<#58)) AND (I1<=Length(S1)) DO
  INC(I1);
 DEC(I1);
 IF I1=0 THEN
  ParseError;
 I3:=0;
 FOR I2:=1 TO I1 DO
  I3:=(I3*10)+ ORD(S1[I2])-48;

{Calc no of bytes(1,2 or 4) required from no of digits found}

 IF (I1<3) THEN
  I2:=1
 ELSE
  IF (I1=3) AND (I3<256) THEN
   I2:=1
  ELSE
   BEGIN
    IF I1<5 THEN
     I2:=2
     ELSE
      IF (I1=5) AND (i3<65536) THEN
       I2:=2
      ELSE
       I2:=4;
   END;
END;

PROCEDURE DoChar;
{ Reads a #xxx constant at S1[1], and puts it in msgtxt array.
    Deletes #xxx constant from S1}

BEGIN
 Delete(S1,1,1);
 FixDec;
 msgtxt[Msgsize]:=CHR(I3);
 inc(msgsize);
 Delete(S1,1,I1);
END;

PROCEDURE DoQuote;
{ Reads a quoted text-string ('xxx' or "xxx"). Quotechar is in S1[1]
  (always ' or "), any char except the quotechar is allowed between two
  quotechars.
    Deletes quoted textstring incl quotes from S1}

VAR C : Char;

BEGIN
  C:=S1[1];
  Delete(S1,1,1);
  I1:=Pos(C,S1);                       {Find other quote}
  IF I1=0 THEN
   ParseError;                    {Quotes have to be matched}
  Dec(I1);
  IF I1<>0 THEN
   BEGIN
    Move(S1[1],Msgtxt[Msgsize],I1);
    INC(msgsize,I1);
   END;
  Delete(S1,1,I1+1);
  LTrim(S1,' ');
END;

PROCEDURE FixHex(base2:LONGINT);
{ Reads a base 2,8 or 16 constant from S1.
  Parameter = 2Log of base (1,3 or 4 corresponding to base 2,8 and 16)
  Constant is processed, the number of digits estimated (1,2 or 4 bytes) and
  the value is appended to msgtxt accordingly}

BEGIN
 I3:=0;
 I2:=1;
 WHILE (S1[I2] IN ['0'..'9','A'..'F','a'..'f']) AND (I2<=Length(S1)) DO
  BEGIN
   IF (S1[I2]>#47) AND (S1[I2]<#58) THEN
    I3:=(I3 SHL base2)+ ORD(S1[I2])-48
   ELSE
    IF (S1[I2]>#64) AND (S1[I2]<#71) THEN
     I3:=(I3 SHL base2)+ ORD(S1[I2])-55
    ELSE
     IF (S1[I2]>#96) AND (S1[I2]<#103) THEN
      I3:=(I3 SHL base2)+ ORD(S1[I2])-87
    ELSE
     ParseError;
    INC(I2);
  END;
 DEC(I2);
 CASE Base2 OF
  4 :   BEGIN
        I4:=(I2 SHR 1);
        IF ODD(I2) THEN
         INC(I4);
        IF I4=3 THEN I4:=4
       END;
  3 :   I4:=(I2*3 DIV 8)+1;
  1 :   BEGIN
         IF I2<9 THEN
          I4:=1
         ELSE
          IF I2<17 THEN
           I4:=2
          ELSE
          I4:=4;
        END;
   ELSE
    BEGIN
     Writeln(' severe internal error ');
     ParseError;
    END; {else}
   END; {Case}
  move(I3,msgtxt[Msgsize],i4);
  inc(msgsize,i4);
END;

PROCEDURE DoTextual;
{ processes aggregates of textual data like 'xxx'+#39"2143124"+'1234'#123}

BEGIN
 REPEAT
  CASE S1[1] OF
   '#' : DoChar;
   '"',#39 : DoQuote;           {Should I support octal codes here?}
  ELSE
   ParseError;
   END;
  LTrim(S1,' ');
  IF (S1[1]='+') THEN
   Delete(S1,1,1);
  LTrim(S1,' ');
 UNTIL Length(S1)=0;
END;

PROCEDURE FlushMsgTxt;            {Flush MsgTxt array}
BEGIN
 IF msgsize>0 THEN          {In memory? Then flush}
  BEGIN
   IF ArrayByte THEN
    WriteByteFile(outfile,Varname)
   ELSE
    WriteCharFile(outfile,varname);
   msgsize:=0;
  END;
END;

{Actual DoFile}
begin
  Getmem(msgtxt,maxbufsize);
  Writeln('processing file : ',inname);
{Read the message file}
  assign(infile,inname);
  {$I-}
   reset(infile);
  {$I+}
  if ioresult<>0 then
   begin
     WriteLn('*** message file '+inname+' not found ***');
     exit;
   end;

{Create output file}

  assign (outfile,outname);
  rewrite(outfile);
  msgsize:=0;
  Line:=0;
  while not eof(infile) do
   begin
    readln(infile,s);      {Read a line}
    INC(Line);
    S1:=Copy(S,1,5);
    Uppercase(S1);
    IF S1='DATA ' THEN   {DATA keyword?}
     BEGIN
      Delete(S,1,5);
      REPEAT
       DataItem:=SpecialItem(S);  {Yes. Determine size of DATA field.}
       IF DataItem<>0 THEN
        BEGIN
         I1:=DataItem;
         IF DataItem=Length(S) THEN
          INC(i1);        {DataItem fix for last field}
         S1:=Copy(S,1,I1-1);    { copy field to S1}
         Delete(S,1,I1);        {Delete field from S}
         LTrim(S1,' ');
         RTrim(S1,' ');
         LTrim(S,' ');
         CASE S1[1] OF        {Select field type}
          #39,'"','#' : DoTextual; { handles textual aggregates
                                     e.g. #124"142"#123'sdgf''ads'}

          '$' : BEGIN         {Handle $xxxx hex codes}
                 Delete(S1,1,1);
                 RTrim(S1,' ');
                 IF Length(S1)>0 THEN
                  FixHex(4)
                 ELSE
                  ParseError;
                 END;
    '0'..'9'  : BEGIN    { handles 0x124,124124,124124H,234h,666o,353d,24b}
                 IF (Length(S1)>1) AND (S1[2]='x') THEN {C style 0xABCD hex}
                  BEGIN
                   Delete(S1,1,2);
                   FixHex(4);
                  END
                 ELSE {other types (HP notation suffix h,o,d and b (and upcase versions,
                                                       and no suffix) }
                  BEGIN
                   CASE S1[Length(S1)] OF
                    'H','h' : FixHex(4);      {Hex}
                    'o','O' : FixHex(3);      {octal}
                        'B','b' : BEGIN       {Binary}
                                   DEC(S1[0]); {avoid 'b' char being treated as
                                                 hex B }
                                   FixHex(1);
                                  END;
               '0'..'9','d','D' : BEGIN      {decimal versions}
                                   FixDec;   {Fixdec is safe for trailing chars}
                                   {I1 =no of digits, I3=value, I2= no bytes needed}
                                   move(I3,msgtxt[Msgsize],i2);
                                   inc(msgsize,i2)
                                  END
                             ELSE
                              ParseError; {otherwise wrong suffix}
                           END {Nested case}
                       END; { IF S1[2]='x'}
                      END; { '0'..'9'}
              '%'   : BEGIN          {%101010 binary constants}
                       Delete(S1,1,1);
                       FixHex(1);
                      END;
              '\'   : BEGIN          {\xxx octal constants}
                       Delete(S1,1,1);
                       FixHex(3);
                      END;
          END; {Case}
         END; {IF <>0}
        UNTIL {(DataItem:=Length(S)) OR} (DataItem=0); {parse until String is empty}
      END {S1='DATA'}
     ELSE
      BEGIN                          {Non DATA line}
       IF (Length(S)<>0) AND NOT (S[1] IN ['#',';','%']) THEN
        BEGIN
         C:=S[1];
         IF NOT XlatString(S) THEN  {Expand \xxx octal constants}
          BEGIN
           Writeln('Some error with a \xxx constant or a stale (unescaped) backslash');
           ParseError;
          END;
         IF C='!' THEN         { New variable}
          BEGIN
           FlushMsgTxt;
           I1:=1;
           ArrayByte:=FALSE;
           IF S[2]='$' THEN      {Flag for ARRAY OF BYTE?}
            BEGIN
             INC(I1);
             ArrayByte:=TRUE;
            END;
           Delete(S,1,I1);
           VarName:=S;
          END
         ELSE
          BEGIN {Normal line}
           i1:=Length(S);
           move(s[1],msgtxt[Msgsize],i1);
           inc(msgsize,i1);
          END;
      END;
    END;
   end;
  close(infile);
  FlushMsgTxt;                    {Flush variable if msgtxt is occupied}
  Close(Outfile);
end;


procedure DoBinary;
var
  Infile  : File;
  Outfile : text;
  i       : longint;
begin
  Writeln('processing file : ',inname);
  {Read the message file}
  assign(infile,inname);
  {$I-}
   reset(infile,1);
  {$I+}
  if ioresult<>0 then
   begin
     WriteLn('*** message file '+inname+' not found ***');
     exit;
   end;
  assign (outfile,outname);
  rewrite(outfile);
{ First parse the file and count bytes needed }
  msgsize:=FileSize(InFile);
  IF Msgsize>1048576 THEN
   msgsize:=1048576;
  Getmem(msgtxt,msgsize);
  BlockRead(InFile,msgTxt[0],msgsize,i);
  IF I<>msgsize THEN
   BEGIN
    Writeln('Error while reading file',inName);
    HALT(1);
   END;
  IF ArrayByte THEN
   WriteByteFile(outfile,BinconstName)
  ELSE
   WriteCharFile(outfile,BinconstName);
  close(infile);
  Close(Outfile);
end;


{*****************************************************************************
                                Main Program
*****************************************************************************}

procedure getpara;
var
  ch      : char;
  para    : string;
  files,i : word;

  procedure helpscreen;
  begin
    writeln('usage : data2inc [Options] <msgfile> [incfile] [constname]');
    Writeln('  The constname parameter is only valid in combination');
    writeln('  with -b, otherwise the constname must be specified in the inputfile');
    Writeln;
    writeln('<Options> can be :');
    writeln('              -B     File to read is binary.');
    writeln('              -A     array of byte output (default is array of char)');
    writeln('              -V     Show version');
    writeln('        -? or -H     This HelpScreen');
    writeln;
    Writeln(' See data2inc.exm for a demonstration source');
    halt(1);
  end;


begin
  I_binary:=FALSE;
  ArrayByte:=FALSE;
  FIles:=0;
  for i:=1to paramcount do
   begin
     para:=paramstr(i);
     if (para[1]='-') then
      begin
        ch:=upcase(para[2]);
        delete(para,1,2);
        case ch of
         'B' : I_Binary:=TRUE;
         'A' : Arraybyte:=TRUE;
         'V' : begin
                 Writeln('Data2Inc ',version,' (C) 1999 Peter Vreman and Marco van de Voort');
                 Writeln;
                 Halt;
               end;
     '?','H' : Helpscreen;

        end;
     end
    else
     begin
       inc(Files);
       if Files>3 then
        HelpScreen;
       case Files of
        1 : InName:=Para;
        2 : OutName:=Para;
        3 : BinConstName:=Para;
       end;
     end;
    END;
   if (FIles<3) AND I_Binary then
     HelpScreen;
   IF Files<2 THEN
    HelpScreen;
end;

begin
 MaxBufSize:=100000;
 GetPara;

 IF I_Binary THEN
  DoBinary
 ELSE
  DoFile;
end.
{
  $Log$
  Revision 1.1  1999-11-09 14:40:50  peter
    * initial version

}