OpenCores
URL https://opencores.org/ocsvn/usb_fpga_2_14/usb_fpga_2_14/trunk

Subversion Repositories usb_fpga_2_14

[/] [usb_fpga_2_14/] [trunk/] [bmp/] [src/] [textbuf.pas] - Blame information for rev 2

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 2 ZTEX
{
2
   bmp -- babel macro processor
3
   Copyright (C) 2009-2017 ZTEX GmbH.
4
   http://www.ztex.de
5
 
6
   This program is free software; you can redistribute it and/or modify
7
   it under the terms of the GNU General Public License version 3 as
8
   published by the Free Software Foundation.
9
 
10
   This program is distributed in the hope that it will be useful, but
11
   WITHOUT ANY WARRANTY; without even the implied warranty of
12
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13
   General Public License for more details.
14
 
15
   You should have received a copy of the GNU General Public License
16
   along with this program; if not, see http://www.gnu.org/licenses/.
17
}
18
 
19
{$mode objfpc}
20
unit textbuf;
21
 
22
interface
23
 
24
const maxspathc   = 1024;
25
      lineInfoPattern : shortstring = '';
26
 
27
type  pdword = ^dword;
28
 
29
      CTextBuf = class;
30
      CTextBuf = class
31
        buf          : pchar;    { character buffer }
32
        li           : pdword;   { line info lineNum shl 12 + file }
33
        lastbuf,d,d0 : longint;
34
        allocsize    : longint;  { allocated size }
35
        last         : CTextBuf;
36
        killme       : boolean;
37
        constructor create(var tb:CTextBuf);
38
        constructor create(var tb:CTextBuf; asize:longint);
39
        constructor create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);
40
        destructor destroy; override;
41
        procedure endbuf; virtual;
42
        end;
43
 
44
      CFileBuf = class(CTextBuf)
45
        constructor create(var tb:CTextBuf; const fn,ep:ansistring);
46
        procedure endbuf; override;
47
       private
48
        fileNum : longint;
49
        line    : longint;
50
        fname   : ansistring;
51
        errStr  : ansistring; { error trefix }
52
        stat    : longint;
53
        f       : file;
54
        end;
55
 
56
var spath  : array[0..maxspathc-1] of ansistring;
57
    spathc : longint;
58
 
59
function getFileNum(const fn:ansistring):longint;
60
function lineInfoStr(li:dword):ansistring;
61
procedure lineInfoStr(var fo:text; li:dword);
62
 
63
implementation
64
 
65
uses dos,bmpsys;
66
const textbuf_size = 2048;
67
 
68
{ ********************************************************************* }
69
{ ****** CTextBuf ***************************************************** }
70
{ ********************************************************************* }
71
{ ****** create ******************************************************* }
72
constructor CTextBuf.create(var tb:CTextBuf);
73
begin
74
lastbuf:=-1;
75
d:=0; d0:=0;
76
killme:=false;
77
last:=tb;
78
tb:=self;
79
end;
80
 
81
constructor CTextBuf.create(var tb:CTextBuf; asize:longint);
82
begin
83
create(tb);
84
getmem(buf,asize);
85
getmem(li,asize*4);
86
allocsize:=asize;
87
end;
88
 
89
constructor CTextBuf.create(var tb:CTextBuf; cb:pchar; lib:pdword; bufsize:longint);
90
begin
91
create(tb);
92
buf:=cb;
93
li:=lib;
94
lastbuf:=bufsize-1;
95
allocsize:=0;
96
end;
97
 
98
{ ****** destroy ****************************************************** }
99
destructor CTextBuf.destroy;
100
begin
101
if allocsize>0 then
102
  begin
103
  freemem(buf,allocsize);
104
  freemem(li,allocsize*4);
105
  end;
106
end;
107
 
108
{ ****** endbuf ******************************************************* }
109
procedure CTextBuf.endbuf;
110
begin
111
killme:=true;
112
end;
113
 
114
{ ********************************************************************* }
115
{ ****** CFileBuf ***************************************************** }
116
{ ********************************************************************* }
117
{ ****** create ******************************************************* }
118
constructor CFileBuf.create(var tb:CTextBuf; const fn,ep:ansistring);
119
begin
120
inherited create(tb,textbuf_size);
121
stat:=0;
122
pointer(fname):=nil;
123
fname:=fn;
124
pointer(errStr):=nil;
125
errStr:=ep;
126
fileNum:=-1;
127
line:=0;
128
end;
129
 
130
{ ****** endbuf ******************************************************* }
131
procedure CFileBuf.endbuf;
132
var i,j  : longint;
133
    e    : dword;
134
    sr   : searchrec;
135
    dir  : dirstr;
136
    name : namestr;
137
    ext  : extstr;
138
    b    : boolean;
139
begin
140
lastbuf:=-1;
141
d0+=d;
142
d:=0;
143
killme:=true;
144
 
145
if stat=0 then
146
  begin
147
  stat:=1;
148
  if fname<>'' then
149
     begin
150
     j:=-1;
151
//     write(fname+':  ');
152
     for i:=0 to spathc-1 do
153
       begin
154
//       write(spath[i]+'   ');
155
       findfirst(spath[i]+fname,$27,sr);
156
       if doserror=0 then
157
          begin
158
          if j<>-1
159
             then bmp_warning(errstr+'`'+spath[i]+fname+''' found, using `'+spath[j]+fname+'''')
160
             else j:=i;
161
          end;
162
       end;
163
//     writeln(':  '+spath[j]+fname);
164
 
165
     if j=-1 then
166
        begin
167
        bmp_error(errstr+'Can not find file: `'+fname+'''');
168
        stat:=2;
169
        exit;
170
        end;
171
 
172
     fsplit(spath[j]+fname,dir,name,ext);
173
     b:=true;
174
     for i:=0 to spathc-1 do
175
       if dir=spath[i] then b:=false;
176
     if b then
177
        begin
178
        if spathc>=maxspathc
179
           then bmp_error(errstr+'Maximum amount of search paths reached')
180
           else begin
181
                spath[spathc]:=dir;
182
                spathc+=1;
183
                end;
184
        end;
185
 
186
     fileNum:=getFileNum(spath[j]+fname);
187
     line:=0;
188
     try
189
       filemode:=0;
190
       assign(f,spath[j]+fname);
191
       reset(f,1);
192
     except
193
       bmp_error(errstr+'Can not open file: '+spath[j]+fname);
194
       fname:='';
195
       stat:=2;
196
       end;
197
     end;
198
  end;
199
 
200
if stat=1 then
201
  begin
202
  if fname=''
203
     then begin
204
          lastbuf:=-1;
205
          while (not(eof(input))) and (lastbuf<textbuf_size-1) do
206
            begin
207
            lastbuf+=1;
208
            read(buf[lastbuf]);
209
            end;
210
          end
211
     else begin
212
          try
213
            blockread(f,buf^,textbuf_size,lastbuf);
214
            lastbuf-=1;
215
          except
216
            bmp_error(errstr+'Can read from file: '+fname);
217
            lastbuf:=-1;
218
            end;
219
          end;
220
 
221
  e:=(line shl 12) + fileNum;
222
  for i:=0 to lastbuf do
223
    begin
224
    if buf[i]=#10 then
225
      begin
226
      e+=4096;
227
      line+=1;
228
      end;
229
    li[i]:=e;
230
    end;
231
 
232
  if lastbuf<textbuf_size-1 then
233
    begin
234
    stat:=2;
235
    if fname<>'' then
236
      begin
237
      try
238
        close(f);
239
      except
240
        end;
241
      end;
242
    end;
243
  end;
244
 
245
if lastbuf>=0 then killme:=false;
246
end;
247
 
248
 
249
{ ********************************************************************* }
250
{ ****** FileCache **************************************************** }
251
{ ********************************************************************* }
252
const fileCount : longint = 0;
253
var fileCache : array[0..2047] of ansistring;
254
 
255
{ ****** getFileNum *************************************************** }
256
function getFileNum(const fn:ansistring):longint;
257
var i  : longint;
258
begin
259
i:=0;
260
while (i<fileCount) and (i<2047) and (fn<>fileCache[i]) do
261
  i+=1;
262
if fn<>fileCache[i] then
263
  begin
264
  i:=fileCount and 2047;
265
  fileCache[i]:=fn;
266
  fileCount+=1;
267
  end;
268
result:=i;
269
end;
270
 
271
{ ****** lineInfoStr ************************************************* }
272
function lineInfoStr(li:dword):ansistring;
273
begin
274
result:=fileCache[li and 2047]+'('+int2str((li shr 12)+1)+')';
275
end;
276
 
277
procedure lineInfoStr(var fo:text; li:dword);
278
var s   : ansistring;
279
    i,j : longint;
280
begin
281
if li and 2048 <> 0 then exit;
282
pointer(s):=nil;
283
i:=1;
284
while i<=length(lineInfoPattern) do
285
  begin
286
  if (lineInfoPattern[i]='%') and (i<length(lineInfoPattern))
287
    then case lineInfoPattern[i+1] of
288
           '1' : begin
289
                 for j:=1 to length(fileCache[li and 2047]) do
290
                   if fileCache[li and 2047][j]='\'
291
                     then s+='\\'
292
                     else s+=fileCache[li and 2047][j];
293
                 i+=1;
294
                 end;
295
           '2' : begin
296
                 s+=int2str(li shr 12);
297
                 i+=1;
298
                 end;
299
           '%' : begin
300
                 s+='%';
301
                 i+=1;
302
                 end;
303
           else s+='%';
304
         end
305
    else s+=lineInfoPattern[i];
306
  i+=1;
307
  end;
308
writeln(fo,s);
309
end;
310
 
311
procedure initFileCache;
312
var i : longint;
313
begin
314
fileCache[0]:='?';
315
for i:=1 to 2047 do
316
  fileCache[i]:=fileCache[0];
317
end;
318
 
319
begin
320
initFileCache;
321
end.

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.