Subversion Repositories usb_fpga_1_15

{*!

{*!

   bmp -- babel macro processor

   bmp -- babel macro processor

   http://www.ztex.de

   http://www.ztex.de

   This program is free software; you can redistribute it and/or modify

   This program is free software; you can redistribute it and/or modify

   it under the terms of the GNU General Public License version 3 as

   it under the terms of the GNU General Public License version 3 as

   published by the Free Software Foundation.

   published by the Free Software Foundation.

   This program is distributed in the hope that it will be useful, but

   This program is distributed in the hope that it will be useful, but

   WITHOUT ANY WARRANTY; without even the implied warranty of

   WITHOUT ANY WARRANTY; without even the implied warranty of

   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

   General Public License for more details.

   General Public License for more details.

   You should have received a copy of the GNU General Public License

   You should have received a copy of the GNU General Public License

   along with this program; if not, see http://www.gnu.org/licenses/.

   along with this program; if not, see http://www.gnu.org/licenses/.

!*}

!*}

{$mode objfpc}

{$mode objfpc}

unit textbuf;

unit textbuf;

interface

interface

const maxspathc   = 1024;

const maxspathc   = 1024;

      lineInfoPattern : shortstring = '';

      lineInfoPattern : shortstring = '';

type  pdword = ^dword;

type  pdword = ^dword;

      CTextBuf = class;

      CTextBuf = class;

      CTextBuf = class

      CTextBuf = class

        buf          : pchar;    { character buffer }

        buf          : pchar;    { character buffer }

        li           : pdword;   { line info lineNum shl 12 + file }

        li           : pdword;   { line info lineNum shl 12 + file }

        lastbuf,d,d0 : longint;

        lastbuf,d,d0 : longint;

        allocsize    : longint;  { allocated size }

        allocsize    : longint;  { allocated size }

        last         : CTextBuf;

        last         : CTextBuf;

        killme       : boolean;

        killme       : boolean;

        constructor create(var tb:CTextBuf);

        constructor create(var tb:CTextBuf);

        constructor create(var tb:CTextBuf; asize:longint);

        constructor create(var tb:CTextBuf; asize:longint);

        constructor create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);

        constructor create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);

        destructor destroy; override;

        destructor destroy; override;

        procedure endbuf; virtual;

        procedure endbuf; virtual;

        end;

        end;

      CFileBuf = class(CTextBuf)

      CFileBuf = class(CTextBuf)

        constructor create(var tb:CTextBuf; const fn,ep:ansistring);

        constructor create(var tb:CTextBuf; const fn,ep:ansistring);

        procedure endbuf; override;

        procedure endbuf; override;

       private

       private

        fileNum : longint;

        fileNum : longint;

        line    : longint;

        line    : longint;

        fname   : ansistring;

        fname   : ansistring;

        errStr  : ansistring; { error trefix }

        errStr  : ansistring; { error trefix }

        stat    : longint;

        stat    : longint;

        f       : file;

        f       : file;

        end;

        end;

var spath  : array[0..maxspathc-1] of ansistring;

var spath  : array[0..maxspathc-1] of ansistring;

    spathc : longint;

    spathc : longint;

function getFileNum(const fn:ansistring):longint;

function getFileNum(const fn:ansistring):longint;

function lineInfoStr(li:dword):ansistring;

function lineInfoStr(li:dword):ansistring;

procedure lineInfoStr(var fo:text; li:dword);

procedure lineInfoStr(var fo:text; li:dword);

implementation

implementation

uses dos,bmpsys;

uses dos,bmpsys;

const textbuf_size = 2048;

const textbuf_size = 2048;

{ ********************************************************************* }

{ ********************************************************************* }

{ ****** CTextBuf ***************************************************** }

{ ****** CTextBuf ***************************************************** }

{ ********************************************************************* }

{ ********************************************************************* }

{ ****** create ******************************************************* }

{ ****** create ******************************************************* }

constructor CTextBuf.create(var tb:CTextBuf);

constructor CTextBuf.create(var tb:CTextBuf);

begin

begin

lastbuf:=-1;

lastbuf:=-1;

d:=0; d0:=0;

d:=0; d0:=0;

killme:=false;

killme:=false;

last:=tb;

last:=tb;

tb:=self;

tb:=self;

end;

end;

constructor CTextBuf.create(var tb:CTextBuf; asize:longint);

constructor CTextBuf.create(var tb:CTextBuf; asize:longint);

begin

begin

create(tb);

create(tb);

getmem(buf,asize);

getmem(buf,asize);

getmem(li,asize*4);

getmem(li,asize*4);

allocsize:=asize;

allocsize:=asize;

end;

end;

constructor CTextBuf.create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);

constructor CTextBuf.create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);

begin

begin

create(tb);

create(tb);

buf:=cb;

buf:=cb;

li:=lib;

li:=lib;

lastbuf:=bufsize-1;

lastbuf:=bufsize-1;

allocsize:=0;

allocsize:=0;

end;

end;

{ ****** destroy ****************************************************** }

{ ****** destroy ****************************************************** }

destructor CTextBuf.destroy;

destructor CTextBuf.destroy;

begin

begin

if allocsize>0 then

if allocsize>0 then

  begin

  begin

  freemem(buf,allocsize);

  freemem(buf,allocsize);

  freemem(li,allocsize*4);

  freemem(li,allocsize*4);

  end;

  end;

end;

end;

{ ****** endbuf ******************************************************* }

{ ****** endbuf ******************************************************* }

procedure CTextBuf.endbuf;

procedure CTextBuf.endbuf;

begin

begin

killme:=true;

killme:=true;

end;

end;

{ ********************************************************************* }

{ ********************************************************************* }

{ ****** CFileBuf ***************************************************** }

{ ****** CFileBuf ***************************************************** }

{ ********************************************************************* }

{ ********************************************************************* }

{ ****** create ******************************************************* }

{ ****** create ******************************************************* }

constructor CFileBuf.create(var tb:CTextBuf; const fn,ep:ansistring);

constructor CFileBuf.create(var tb:CTextBuf; const fn,ep:ansistring);

begin

begin

inherited create(tb,textbuf_size);

inherited create(tb,textbuf_size);

stat:=0;

stat:=0;

pointer(fname):=nil;

pointer(fname):=nil;

fname:=fn;

fname:=fn;

pointer(errStr):=nil;

pointer(errStr):=nil;

errStr:=ep;

errStr:=ep;

fileNum:=-1;

fileNum:=-1;

line:=0;

line:=0;

end;

end;

{ ****** endbuf ******************************************************* }

{ ****** endbuf ******************************************************* }

procedure CFileBuf.endbuf;

procedure CFileBuf.endbuf;

var i,j  : longint;

var i,j  : longint;

    e    : dword;

    e    : dword;

    sr   : searchrec;

    sr   : searchrec;

    dir  : dirstr;

    dir  : dirstr;

    name : namestr;

    name : namestr;

    ext  : extstr;

    ext  : extstr;

    b    : boolean;

    b    : boolean;

begin

begin

lastbuf:=-1;

lastbuf:=-1;

d0+=d;

d0+=d;

d:=0;

d:=0;

killme:=true;

killme:=true;

if stat=0 then

if stat=0 then

  begin

  begin

  stat:=1;

  stat:=1;

  if fname<>'' then

  if fname<>'' then

     begin

     begin

     j:=-1;

     j:=-1;

//     write(fname+':  ');

//     write(fname+':  ');

     for i:=0 to spathc-1 do

     for i:=0 to spathc-1 do

       begin

       begin

//       write(spath[i]+'   ');

//       write(spath[i]+'   ');

       findfirst(spath[i]+fname,$27,sr);

       findfirst(spath[i]+fname,$27,sr);

       if doserror=0 then

       if doserror=0 then

          begin

          begin

          if j<>-1

          if j<>-1

             then bmp_warning(errstr+'`'+spath[i]+fname+''' found, using `'+spath[j]+fname+'''')

             then bmp_warning(errstr+'`'+spath[i]+fname+''' found, using `'+spath[j]+fname+'''')

             else j:=i;

             else j:=i;

          end;

          end;

       end;

       end;

//     writeln(':  '+spath[j]+fname);

//     writeln(':  '+spath[j]+fname);

     if j=-1 then

     if j=-1 then

        begin

        begin

        bmp_error(errstr+'Can not find file: `'+fname+'''');

        bmp_error(errstr+'Can not find file: `'+fname+'''');

        stat:=2;

        stat:=2;

        exit;

        exit;

        end;

        end;

     fsplit(spath[j]+fname,dir,name,ext);

     fsplit(spath[j]+fname,dir,name,ext);

     b:=true;

     b:=true;

     for i:=0 to spathc-1 do

     for i:=0 to spathc-1 do

       if dir=spath[i] then b:=false;

       if dir=spath[i] then b:=false;

     if b then

     if b then

        begin

        begin

        if spathc>=maxspathc

        if spathc>=maxspathc

           then bmp_error(errstr+'Maximum amount of search paths reached')

           then bmp_error(errstr+'Maximum amount of search paths reached')

           else begin

           else begin

                spath[spathc]:=dir;

                spath[spathc]:=dir;

                spathc+=1;

                spathc+=1;

                end;

                end;

        end;

        end;

     fileNum:=getFileNum(spath[j]+fname);

     fileNum:=getFileNum(spath[j]+fname);

     line:=0;

     line:=0;

     try

     try

       filemode:=0;

       filemode:=0;

       assign(f,spath[j]+fname);

       assign(f,spath[j]+fname);

       reset(f,1);

       reset(f,1);

     except

     except

       bmp_error(errstr+'Can not open file: '+spath[j]+fname);

       bmp_error(errstr+'Can not open file: '+spath[j]+fname);

       fname:='';

       fname:='';

       stat:=2;

       stat:=2;

       end;

       end;

     end;

     end;

  end;

  end;

if stat=1 then

if stat=1 then

  begin

  begin

  if fname=''

  if fname=''

     then begin

     then begin

          lastbuf:=-1;

          lastbuf:=-1;

          while (not(eof(input))) and (lastbuf<textbuf_size-1) do

          while (not(eof(input))) and (lastbuf<textbuf_size-1) do

            begin

            begin

            lastbuf+=1;

            lastbuf+=1;

            read(buf[lastbuf]);

            read(buf[lastbuf]);

            end;

            end;

          end

          end

     else begin

     else begin

          try

          try

            blockread(f,buf^,textbuf_size,lastbuf);

            blockread(f,buf^,textbuf_size,lastbuf);

            lastbuf-=1;

            lastbuf-=1;

          except

          except

            bmp_error(errstr+'Can read from file: '+fname);

            bmp_error(errstr+'Can read from file: '+fname);

            lastbuf:=-1;

            lastbuf:=-1;

            end;

            end;

          end;

          end;

  e:=(line shl 12) + fileNum;

  e:=(line shl 12) + fileNum;

  for i:=0 to lastbuf do

  for i:=0 to lastbuf do

    begin

    begin

    if buf[i]=#10 then

    if buf[i]=#10 then

      begin

      begin

      e+=4096;

      e+=4096;

      line+=1;

      line+=1;

      end;

      end;

    li[i]:=e;

    li[i]:=e;

    end;

    end;

  if lastbuf<textbuf_size-1 then

  if lastbuf<textbuf_size-1 then

    begin

    begin

    stat:=2;

    stat:=2;

    if fname<>'' then

    if fname<>'' then

      begin

      begin

      try

      try

        close(f);

        close(f);

      except

      except

        end;

        end;

      end;

      end;

    end;

    end;

  end;

  end;

if lastbuf>=0 then killme:=false;

if lastbuf>=0 then killme:=false;

end;

end;

{ ********************************************************************* }

{ ********************************************************************* }

{ ****** FileCache **************************************************** }

{ ****** FileCache **************************************************** }

{ ********************************************************************* }

{ ********************************************************************* }

const fileCount : longint = 0;

const fileCount : longint = 0;

var fileCache : array[0..2047] of ansistring;

var fileCache : array[0..2047] of ansistring;

{ ****** getFileNum *************************************************** }

{ ****** getFileNum *************************************************** }

function getFileNum(const fn:ansistring):longint;

function getFileNum(const fn:ansistring):longint;

var i  : longint;

var i  : longint;

begin

begin

i:=0;

i:=0;

while (i<fileCount) and (i<2047) and (fn<>fileCache[i]) do

while (i<fileCount) and (i<2047) and (fn<>fileCache[i]) do

  i+=1;

  i+=1;

if fn<>fileCache[i] then

if fn<>fileCache[i] then

  begin

  begin

  i:=fileCount and 2047;

  i:=fileCount and 2047;

  fileCache[i]:=fn;

  fileCache[i]:=fn;

  fileCount+=1;

  fileCount+=1;

  end;

  end;

result:=i;

result:=i;

end;

end;

{ ****** lineInfoStr ************************************************* }

{ ****** lineInfoStr ************************************************* }

function lineInfoStr(li:dword):ansistring;

function lineInfoStr(li:dword):ansistring;

begin

begin

result:=fileCache[li and 2047]+'('+int2str((li shr 12)+1)+')';

result:=fileCache[li and 2047]+'('+int2str((li shr 12)+1)+')';

end;

end;

procedure lineInfoStr(var fo:text; li:dword);

procedure lineInfoStr(var fo:text; li:dword);

var s   : ansistring;

var s   : ansistring;

    i,j : longint;

    i,j : longint;

begin

begin

if li and 2048 <> 0 then exit;

if li and 2048 <> 0 then exit;

pointer(s):=nil;

pointer(s):=nil;

i:=1;

i:=1;

while i<=length(lineInfoPattern) do

while i<=length(lineInfoPattern) do

  begin

  begin

  if (lineInfoPattern[i]='%') and (i<length(lineInfoPattern))

  if (lineInfoPattern[i]='%') and (i<length(lineInfoPattern))

    then case lineInfoPattern[i+1] of

    then case lineInfoPattern[i+1] of

           '1' : begin

           '1' : begin

                 for j:=1 to length(fileCache[li and 2047]) do

                 for j:=1 to length(fileCache[li and 2047]) do

                   if fileCache[li and 2047][j]='\'

                   if fileCache[li and 2047][j]='\'

                     then s+='\\'

                     then s+='\\'

                     else s+=fileCache[li and 2047][j];

                     else s+=fileCache[li and 2047][j];

                 i+=1;

                 i+=1;

                 end;

                 end;

           '2' : begin

           '2' : begin

                 s+=int2str(li shr 12);

                 s+=int2str(li shr 12);

                 i+=1;

                 i+=1;

                 end;

                 end;

           '%' : begin

           '%' : begin

                 s+='%';

                 s+='%';

                 i+=1;

                 i+=1;

                 end;

                 end;

           else s+='%';

           else s+='%';

         end

         end

    else s+=lineInfoPattern[i];

    else s+=lineInfoPattern[i];

  i+=1;

  i+=1;

  end;

  end;

writeln(fo,s);

writeln(fo,s);

end;

end;

procedure initFileCache;

procedure initFileCache;

var i : longint;

var i : longint;

begin

begin

fileCache[0]:='?';

fileCache[0]:='?';

for i:=1 to 2047 do

for i:=1 to 2047 do

  fileCache[i]:=fileCache[0];

  fileCache[i]:=fileCache[0];

end;

end;

begin

begin

initFileCache;

initFileCache;

end.

end.