Subversion Repositories usb_fpga_2_14

{

   bmp -- babel macro processor

   Copyright (C) 2009-2017 ZTEX GmbH.

   http://www.ztex.de

   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

   published by the Free Software Foundation.

   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. See the GNU

   General Public License for more details.

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

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

}

{$mode objfpc}

unit textbuf;

interface

const maxspathc   = 1024;

      lineInfoPattern : shortstring = '';

type  pdword = ^dword;

      CTextBuf = class;

      CTextBuf = class

        buf          : pchar;    { character buffer }

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

        lastbuf,d,d0 : longint;

        allocsize    : longint;  { allocated size }

        last         : CTextBuf;

        killme       : boolean;

        constructor create(var tb:CTextBuf);

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

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

        destructor destroy; override;

        procedure endbuf; virtual;

        end;

      CFileBuf = class(CTextBuf)

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

        procedure endbuf; override;

       private

        fileNum : longint;

        line    : longint;

        fname   : ansistring;

        errStr  : ansistring; { error trefix }

        stat    : longint;

        f       : file;

        end;

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

    spathc : longint;

function getFileNum(const fn:ansistring):longint;

function lineInfoStr(li:dword):ansistring;

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

implementation

uses dos,bmpsys;

const textbuf_size = 2048;

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

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

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

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

constructor CTextBuf.create(var tb:CTextBuf);

begin

lastbuf:=-1;

d:=0; d0:=0;

killme:=false;

last:=tb;

tb:=self;

end;

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

begin

create(tb);

getmem(buf,asize);

getmem(li,asize*4);

allocsize:=asize;

end;

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

begin

create(tb);

buf:=cb;

li:=lib;

lastbuf:=bufsize-1;

allocsize:=0;

end;

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

destructor CTextBuf.destroy;

begin

if allocsize>0 then

  begin

  freemem(buf,allocsize);

  freemem(li,allocsize*4);

  end;

end;

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

procedure CTextBuf.endbuf;

begin

killme:=true;

end;

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

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

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

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

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

begin

inherited create(tb,textbuf_size);

stat:=0;

pointer(fname):=nil;

fname:=fn;

pointer(errStr):=nil;

errStr:=ep;

fileNum:=-1;

line:=0;

end;

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

procedure CFileBuf.endbuf;

var i,j  : longint;

    e    : dword;

    sr   : searchrec;

    dir  : dirstr;

    name : namestr;

    ext  : extstr;

    b    : boolean;

begin

lastbuf:=-1;

d0+=d;

d:=0;

killme:=true;

if stat=0 then

  begin

  stat:=1;

  if fname<>'' then

     begin

     j:=-1;

//     write(fname+':  ');

     for i:=0 to spathc-1 do

       begin

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

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

       if doserror=0 then

          begin

          if j<>-1

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

             else j:=i;

          end;

       end;

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

     if j=-1 then

        begin

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

        stat:=2;

        exit;

        end;

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

     b:=true;

     for i:=0 to spathc-1 do

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

     if b then

        begin

        if spathc>=maxspathc

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

           else begin

                spath[spathc]:=dir;

                spathc+=1;

                end;

        end;

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

     line:=0;

     try

       filemode:=0;

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

       reset(f,1);

     except

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

       fname:='';

       stat:=2;

       end;

     end;

  end;

if stat=1 then

  begin

  if fname=''

     then begin

          lastbuf:=-1;

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

            begin

            lastbuf+=1;

            read(buf[lastbuf]);

            end;

          end

     else begin

          try

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

            lastbuf-=1;

          except

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

            lastbuf:=-1;

            end;

          end;

  e:=(line shl 12) + fileNum;

  for i:=0 to lastbuf do

    begin

    if buf[i]=#10 then

      begin

      e+=4096;

      line+=1;

      end;

    li[i]:=e;

    end;

  if lastbuf<textbuf_size-1 then

    begin

    stat:=2;

    if fname<>'' then

      begin

      try

        close(f);

      except

        end;

      end;

    end;

  end;

if lastbuf>=0 then killme:=false;

end;

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

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

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

const fileCount : longint = 0;

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

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

function getFileNum(const fn:ansistring):longint;

var i  : longint;

begin

i:=0;

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

  i+=1;

if fn<>fileCache[i] then

  begin

  i:=fileCount and 2047;

  fileCache[i]:=fn;

  fileCount+=1;

  end;

result:=i;

end;

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

function lineInfoStr(li:dword):ansistring;

begin

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

end;

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

var s   : ansistring;

    i,j : longint;

begin

if li and 2048 <> 0 then exit;

pointer(s):=nil;

i:=1;

while i<=length(lineInfoPattern) do

  begin

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

    then case lineInfoPattern[i+1] of

           '1' : begin

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

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

                     then s+='\\'

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

                 i+=1;

                 end;

           '2' : begin

                 s+=int2str(li shr 12);

                 i+=1;

                 end;

           '%' : begin

                 s+='%';

                 i+=1;

                 end;

           else s+='%';

         end

    else s+=lineInfoPattern[i];

  i+=1;

  end;

writeln(fo,s);

end;

procedure initFileCache;

var i : longint;

begin

fileCache[0]:='?';

for i:=1 to 2047 do

  fileCache[i]:=fileCache[0];

end;

begin

initFileCache;

end.