fpc/compiler/utils/msg2inc.pp
2025-02-25 13:18:44 +02:00

861 lines
20 KiB
ObjectPascal

{
This program is part of the Free Pascal run time library.
Copyright (c) 1998-2002 by Peter Vreman
Convert a .msg file to an .inc file with a const array of char
And for the lazy docwriters it can also generate some TeX output
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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.
**********************************************************************}
{$H+}
program msg2inc;
{$ifdef unix}
{$define EOL_ONE_CHAR}
{$endif unix}
{$ifdef amiga}
{$define EOL_ONE_CHAR}
{$endif amiga}
{$ifdef morphos}
{$define EOL_ONE_CHAR}
{$endif}
{$ifdef macos}
{$define EOL_ONE_CHAR}
{$endif}
{$ifdef wasi}
{$define EOL_ONE_CHAR}
{$endif}
const
version='1.00';
{$ifdef EOL_ONE_CHAR}
eollen=1;
{$else}
eollen=2;
{$endif}
msgparts = 20;
type
TMode=(M_Char,M_Tex,M_Intel,M_String,M_Renumber);
var
InFile,
OutFile,
OutName : string;
Mode : TMode;
TexHeader : boolean;
MsgTxt : pchar;
EnumTxt : pchar;
enumsize,
msgsize : longint;
msgidxmax : array[1..msgparts] of longint;
msgs : array[0..msgparts,0..999] of boolean;
msgcodepage: TSystemCodePage;
procedure LoadMsgFile(const fn:string);
var
f : text;
error,
multiline : boolean;
code : word;
numpart,numidx,
line,i,j,num : longint;
ptxt,
penum : pchar;
number,
s,s1 : string;
procedure err(const msgstr:string);
begin
writeln('error in line ',line,': ',msgstr);
error:=true;
end;
begin
Writeln('Loading messagefile ',fn);
msgcodepage:=CP_ACP;
{Read the message file}
assign(f,fn);
{$push} {$I-}
reset(f);
{$pop}
if ioresult<>0 then
begin
WriteLn('fatal error: '+fn+' not found');
halt(1);
end;
{ First parse the file and count bytes needed }
fillchar(msgidxmax,sizeof(msgidxmax),0);
fillchar(msgs,sizeof(msgs),0);
error:=false;
line:=0;
multiline:=false;
msgsize:=0;
while not eof(f) do
begin
readln(f,s);
inc(line);
if multiline then
begin
if s=']' then
multiline:=false
else if (s='') or (s[1] <> '#') then
inc(msgsize,length(s)+1); { +1 for linebreak }
end
else
begin
if (s<>'') and not(s[1] in ['#',';','%']) then
begin
i:=pos('=',s);
if i>0 then
begin
j:=i+1;
if not(s[j] in ['0'..'9']) then
err('no number found')
else
begin
while (s[j] in ['0'..'9']) do
inc(j);
end;
if j-i-1<>5 then
err('number length is not 5');
number:=Copy(s,i+1,j-i-1);
{ update the max index }
val(number,num,code);
numpart:=num div 1000;
if numpart=0 then
err('number should be > 1000');
if code<>0 then
err('illegal number: '+s);
numidx:=num mod 1000;
{ duplicate ? }
if msgs[numpart,numidx] then
err('duplicate number found');
msgs[numpart,numidx]:=true;
{ check range }
if numpart > msgparts then
err('number is to large')
else
if numidx > msgidxmax[numpart] then
msgidxmax[numpart]:=numidx;
if s[j+1]='[' then
begin
inc(msgsize,j-i);
multiline:=true
end
else
inc(msgsize,length(s)-i+1);
inc(enumsize,j);
end
else
err('no = found');
end
else if (Length(s)>11) and (Copy(s,1,11)='# CodePage ') then
begin
val(Copy(s,12,Length(s)-11),msgcodepage,code);
if code<>0 then
err('illegal code page number: '+s);
end;
end;
end;
if multiline then
err('still in multiline mode');
if error then
begin
close(f);
writeln('aborting');
halt(1);
end;
{ alloc memory }
getmem(msgtxt,msgsize);
{ no linebreak after last entry }
dec(msgsize);
ptxt:=msgtxt;
getmem(enumtxt,enumsize);
penum:=enumtxt;
{ now read the buffer in mem }
reset(f);
while not eof(f) do
begin
readln(f,s);
if multiline then
begin
if s=']' then
begin
multiline:=false;
{ overwrite last eol }
dec(ptxt);
ptxt^:=#0;
inc(ptxt);
end
else if (s='') or (s[1] <> '#') then
begin
if length(s)>0 then
begin
move(s[1],ptxt^,length(s));
inc(ptxt,length(s));
end;
ptxt^:=#10;
inc(ptxt);
end;
end
else
begin
if (s<>'') and not(s[1] in ['#',';','%']) then
begin
i:=pos('=',s);
if i>0 then
begin
j:=i+1;
while (s[j] in ['0'..'9']) do
inc(j);
{enum}
move(s[1],penum^,i-1);
inc(penum,i-1);
penum^:='=';
inc(penum);
number:=Copy(s,i+1,j-i-1);
move(number[1],penum^,length(number));
inc(penum,length(number));
penum^:=#0;
inc(penum);
{ multiline start then no txt }
if s[j+1]='[' then
begin
s1:=Copy(s,i+1,j-i);
move(s1[1],ptxt^,length(s1));
inc(ptxt,length(s1));
multiline:=true;
end
else
begin
{ txt including number }
s1:=Copy(s,i+1,255);
move(s1[1],ptxt^,length(s1));
inc(ptxt,length(s1));
ptxt^:=#0;
inc(ptxt);
end;
end;
end;
end;
end;
close(f);
end;
{*****************************************************************************
WriteEnumFile
*****************************************************************************}
procedure WriteEnumFile(const fn:string);
var
t : text;
i : longint;
p : pchar;
start : boolean;
begin
writeln('Writing enumfile '+fn);
{Open textfile}
assign(t,fn);
rewrite(t);
writeln(t,'const');
{Parse buffer in msgbuf and create indexs}
p:=enumtxt;
start:=true;
for i:=1 to enumsize do
begin
if start then
begin
write(t,' ');
start:=false;
end;
if p^=#0 then
begin
writeln(t,';');
start:=true;
end
else
begin
write(t,p^);
end;
inc(p);
end;
writeln(t,'');
{ msgtxt size }
writeln(t,' MsgTxtSize = ',msgsize,';');
writeln(t,'');
{ max msg idx table }
writeln(t,' MsgIdxMax : array[1..20] of longint=(');
write(t,' ');
for i:=1 to 20 do
begin
write(t,msgidxmax[i]+1);
if i<20 then
write(t,',');
if i=10 then
begin
writeln(t,'');
write(t,' ');
end;
end;
writeln(t,'');
writeln(t,' );');
close(t);
end;
{*****************************************************************************
WriteStringFile
*****************************************************************************}
procedure WriteStringFile(const fn,constname:string);
const
maxslen=240; { to overcome aligning problems }
function l0(l:longint):string;
var
s : string[16];
begin
str(l,s);
while (length(s)<5) do
s:='0'+s;
l0:=s;
end;
var
t : text;
f : file;
slen,
len,i : longint;
p : pchar;
s : string;
start,
quote : boolean;
begin
writeln('Writing stringfile ',fn);
{Open textfile}
assign(t,fn);
rewrite(t);
writeln(t,'const '+constname+'_codepage=',msgcodepage:5,';');
writeln(t,'{$ifdef Delphi}');
writeln(t,'const '+constname+' : array[0..000000] of string[',maxslen,']=(');
writeln(t,'{$else Delphi}');
writeln(t,'const '+constname+' : array[0..000000,1..',maxslen,'] of char=(');
write(t,'{$endif Delphi}');
{Parse buffer in msgbuf and create indexs}
p:=msgtxt;
slen:=0;
len:=0;
quote:=false;
start:=true;
for i:=1 to msgsize do
begin
if slen>=maxslen then
begin
if quote then
begin
write(t,'''');
quote:=false;
end;
write(t,',');
slen:=0;
inc(len);
end;
if (len>70) or (start) then
begin
if quote then
begin
write(t,'''');
quote:=false;
end;
if slen>0 then
writeln(t,'+')
else
writeln(t);
len:=0;
start:=false;
end;
if (len=0) then
write(t,' ');
if (ord(p^)>=32) and (p^<>#39) then
begin
if not quote then
begin
write(t,'''');
quote:=true;
inc(len);
end;
write(t,p^);
inc(len);
end
else
begin
if quote then
begin
write(t,'''');
inc(len);
quote:=false;
end;
write(t,'#'+chr(ord(p^) div 100+48)+chr((ord(p^) mod 100) div 10+48)+chr(ord(p^) mod 10+48));
inc(len,3);
end;
if p^ in [#0,#10] then
start:=true;
inc(slen);
inc(p);
end;
if quote then
write(t,'''');
writeln(t,'');
writeln(t,');');
close(t);
{update arraysize}
s:=l0((msgsize-1) div maxslen); { we start with 0 }
assign(f,fn);
reset(f,1);
seek(f,22+34+2*eollen+2*length(constname));
blockwrite(f,s[1],5);
seek(f,22+90+4*eollen+3*length(constname));
blockwrite(f,s[1],5);
close(f);
end;
{*****************************************************************************
WriteCharFile
*****************************************************************************}
procedure WriteCharFile(const fn,constname:string);
function l0(l:longint):string;
var
s : string[16];
begin
str(l,s);
while (length(s)<5) do
s:='0'+s;
l0:=s;
end;
function createconst(b:byte):string;
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
t : text;
f : file;
cidx,i : longint;
p : pchar;
s : string;
begin
writeln('Writing charfile '+fn);
{Open textfile}
assign(t,fn);
rewrite(t);
writeln(t,'const ',constname,' : array[1..00000] of char=(');
{Parse buffer in msgbuf and create indexs}
p:=msgtxt;
cidx:=0;
for i:=1to msgsize 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,');');
close(t);
{update arraysize}
s:=l0(msgsize);
assign(f,fn);
reset(f,1);
seek(f,18+length(constname));
blockwrite(f,s[1],5);
close(f);
end;
{*****************************************************************************
WriteIntelFile
*****************************************************************************}
procedure WriteIntelFile(const fn,constname:string);
var
t : text;
len,i : longint;
p : pchar;
start,
quote : boolean;
begin
writeln('Writing Intelfile ',fn);
{Open textfile}
assign(t,fn);
rewrite(t);
writeln(t,'procedure '+constname+';assembler;');
writeln(t,'asm');
{Parse buffer in msgbuf and create indexs}
p:=msgtxt;
len:=0;
start:=true;
quote:=false;
for i:=1to msgsize do
begin
if len>70 then
begin
if quote then
begin
write(t,'''');
quote:=false;
end;
writeln(t,'');
start:=true;
end;
if start then
begin
write(t,' db ''');
len:=0;
quote:=true;
end;
if (ord(p^)>=32) and (p^<>#39) then
begin
if not quote then
begin
write(t,',''');
quote:=true;
inc(len);
end;
write(t,p^);
inc(len);
end
else
begin
if quote then
begin
write(t,'''');
inc(len);
quote:=false;
end;
write(t,','+chr(ord(p^) div 100+48)+chr((ord(p^) mod 100) div 10+48)+chr(ord(p^) mod 10+48));
inc(len,4);
end;
inc(p);
end;
if quote then
write(t,'''');
writeln(t,'');
writeln(t,'end;');
close(t);
end;
{*****************************************************************************
RenumberFile
*****************************************************************************}
procedure RenumberFile(const fn,name:string);
var
f,t : text;
i : longint;
s,s1 : string;
begin
Writeln('Renumbering ',fn);
{Read the message file}
assign(f,fn);
{$push} {$I-}
reset(f);
{$pop}
if ioresult<>0 then
begin
WriteLn('*** message file '+fn+' not found ***');
exit;
end;
assign(t,'msg2inc.$$$');
rewrite(t);
i:=0;
while not eof(f) do
begin
readln(f,s);
if (copy(s,1,length(Name))=Name) and (s[3] in ['0'..'9']) then
begin
inc(i);
str(i,s1);
while length(s1)<3 do
s1:='0'+s1;
writeln(t,Name+s1+Copy(s,6,255));
end
else
writeln(t,s);
end;
close(t);
close(f);
{ rename new file }
erase(f);
rename(t,fn);
end;
{*****************************************************************************
WriteTexFile
*****************************************************************************}
Function EscapeString (Const S : String) : String;
Var
I : longint;
hs : string;
begin
hs:='';
i:=1;
while i<=length(s) do
begin
case S[i] of
'$' :
if (s[i+1] in ['0'..'9']) then
begin
hs:=hs+'\textlangle arg. '+s[i+1]+'\textrangle{}';
inc(i);
end
else
hs:=hs+'\$';
'&','{','}','#','_','%': // Escape these characters
hs := hs + '\' + S[i];
'~','^':
hs := hs + '\'+S[i]+' ';
'\':
hs:=hs+'$\backslash$'
else
hs := hs + S[i];
end;
inc(i);
end;
EscapeString:=hs;
end;
procedure WriteTexFile(const infn,outfn:string);
var
t,f : text;
line,
i,k : longint;
number,
s,s1 : string;
texoutput : boolean;
begin
Writeln('Loading messagefile ',infn);
writeln('Writing TeXfile ',outfn);
{ Open infile }
assign(f,infn);
{$push} {$I-}
reset(f);
{$pop}
if ioresult<>0 then
begin
WriteLn('*** message file '+infn+' not found ***');
exit;
end;
{ Open outfile }
assign(t,outfn);
rewrite(t);
If texheader then
begin
writeln (t,'\documentclass{article}');
writeln (t,'\usepackage{html}');
writeln (t,'\usepackage{fpc}');
writeln (t,'\begin{document}');
end;
{ Parse }
line:=0;
TexOutput:=False;
while not eof(f) do
begin
readln(f,s);
inc(line);
If Pos ('# BeginOfTeX',S)=1 then
TexOutPut:=True
else if pos ('# EndOfTeX',S)=1 then
TexOutPut:=False;
if (s<>'') and not(s[1] in ['#',';']) and TeXOutPut then
begin
if s[1]='%' then
begin
Delete(s,1,1);
writeln(t,s);
end
else
begin
i:=pos('=',s);
if i>0 then
begin
inc(i);
number:='';
while s[i] in ['0'..'9'] do
begin
number:=number+s[i];
inc(i);
end;
{ strip leading zeros }
while number[1]='0' do
Delete(number,1,1);
inc(i);
s1:='';
k:=0;
while (k<5) and (s[i+k]<>'_') do
begin
case s[i+k] of
'W' : s1:='Warning '+number+': ';
'E' : s1:='Error '+number+': ';
'F' : s1:='Fatal error '+number+': ';
'N' : s1:='Note '+number+': ';
'I' : s1:='Info '+number+': ';
'H' : s1:='Hint '+number+': ';
end;
inc(k);
end;
if s[i+k]='_' then
inc(i,k+1);
if number<>'' then
writeln(t,'\index[msgnr]{',number,'}');
writeln(t,'\index[msgtxt]{',escapestring(Copy(s,i,255)),'}');
writeln(t,'\item ['+s1+escapestring(Copy(s,i,255))+'] \hfill \\');
end
else
writeln('error in line: ',line,' skipping');
end;
end;
end;
If TexHeader then
writeln (t,'\end{document}');
close(t);
close(f);
end;
{*****************************************************************************
Main Program
*****************************************************************************}
procedure getpara;
var
ch : char;
para : string;
files,i : word;
procedure helpscreen;
begin
writeln('usage : msg2inc [Options] <msgfile> <incfile> <constname>');
writeln('<Options> can be : -T Create .doc TeX file');
writeln(' -TS Create .doc TeX file (stand-alone)');
writeln(' -I Intel style asm output');
writeln(' -S array of string');
writeln(' -C array of char');
writeln(' -R renumber section <incfile>');
writeln(' -V Show version');
writeln(' -? or -H This HelpScreen');
halt(1);
end;
begin
Files:=0;
for i:=1 to paramcount do
begin
para:=paramstr(i);
if (para[1]='-') then
begin
ch:=upcase(para[2]);
delete(para,1,2);
case ch of
'T' : begin
case upcase(para[1]) of
'S' : TexHeader:=True;
end;
Mode:=M_Tex;
end;
'I' : Mode:=M_Intel;
'S' : Mode:=M_String;
'C' : Mode:=M_Char;
'R' : Mode:=M_Renumber;
'V' : begin
Writeln('Msg2Inc ',version,' for Free Pascal (C) 1998-2002 Peter Vreman');
Writeln;
Halt;
end;
'?','H' : helpscreen;
end;
end
else
begin
inc(Files);
if Files>3 then
HelpScreen;
case Files of
1 : InFile:=Para;
2 : OutFile:=Para;
3 : OutName:=Para;
end;
end;
end;
case Mode of
M_Renumber,
M_Tex : if Files<2 then
Helpscreen;
else
if Files<3 then
HelpScreen;
end;
end;
begin
Mode:=M_String;
OutFile:='';
InFile:='';
OutName:='';
GetPara;
case Mode of
M_Renumber : begin
Renumberfile(Infile,OutFile);
end;
M_Tex : begin
WriteTexFile(InFile,Outfile);
end;
M_Intel : begin
Loadmsgfile(InFile);
WriteEnumFile(OutFile+'idx.inc');
WriteIntelFile(OutFile+'txt.inc',OutName+'txt');
end;
M_String : begin
Loadmsgfile(InFile);
WriteEnumFile(OutFile+'idx.inc');
WriteStringFile(OutFile+'txt.inc',OutName+'txt');
end;
M_Char : begin
Loadmsgfile(InFile);
WriteEnumFile(OutFile+'idx.inc');
WriteCharFile(OutFile+'txt.inc',OutName+'txt');
end;
end;
end.