← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/utils/data2inc.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/utils/data2inc.pp
 
1
{
 
2
    Copyright (c) 1999-2000 by Peter Vreman (msg2inc) and
 
3
                          Marco van de Voort (data2inc)
 
4
    Placed under LGPL (See the file COPYING.FPC, included in this
 
5
    distribution, for details about the copyright)
 
6
 
 
7
    E-Mail Marco : Marcov@stack.nl
 
8
    Homepage Marco: www.stack.nl/~marcov/xtdlib.htm
 
9
 
 
10
    Data2Inc is a heavily modified version of msg2inc.pp which compiles the
 
11
     inputfile to include files containing array of char( or byte) typed
 
12
     constants.
 
13
 
 
14
     (e.g. CONST xxx : ARRAY[0..xxx] OF CHAR =( aa,bb,cc,dd,ee); ,
 
15
     or the same but ARRAY OF BYTE )
 
16
 
 
17
    Two types of input file are allowed:
 
18
 
 
19
    1 A special kind of textfile. Records start with '!'name and all following
 
20
       non empty and non comment (starting with '#',':' or '%') lines until
 
21
       the next line starting with '!' or EOF are the data. Data are either
 
22
       plain text (with \xxx ordinal constants) lines or a kinbd of
 
23
       Basic DATA command (these lines start with DATA).
 
24
       See demo.txt included with this package for a commented example.
 
25
 
 
26
    2  (special parameter -b)
 
27
       An arbitrary binary file can get converted to constants. In this mode
 
28
        only one constant per include file is possible.
 
29
 
 
30
    This program is distributed in the hope that it will be useful,
 
31
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
32
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
33
 
 
34
 **********************************************************************}
 
35
program data2inc;
 
36
uses strings;
 
37
 
 
38
CONST
 
39
  version='1.00';
 
40
 
 
41
  maxbufsize = 1024*1024;  { 1 mb buffer }
 
42
 
 
43
type
 
44
  TOutputMode=(OutByte,OutChar,OutString);
 
45
 
 
46
 
 
47
{*****************************************************************************
 
48
            Simple service routines. These are copied from EPasStr.
 
49
*****************************************************************************}
 
50
 
 
51
TYPE CHARSET=SET OF CHAR;
 
52
 
 
53
FUNCTION NextCharPos(CONST S : String;C:CHAR;Count:LONGINT):LONGINT;
 
54
 
 
55
VAR I,J:LONGINT;
 
56
 
 
57
BEGIN
 
58
 I:=ORD(S[0]);
 
59
 IF I=0 THEN
 
60
  J:=0
 
61
 ELSE
 
62
  BEGIN
 
63
   J:=Count;
 
64
  IF J>I THEN
 
65
   BEGIN
 
66
    NextCharPos:=0;
 
67
    EXIT
 
68
   END;
 
69
  WHILE (S[J]<>C) AND (J<=I) DO INC(J);
 
70
   IF (J>I) THEN
 
71
    J:=0;
 
72
  END;
 
73
 NextCharPos:=J;
 
74
END;
 
75
 
 
76
FUNCTION NextCharPosSet(CONST S : String;CONST C:CHARSET;Count:LONGINT):LONGINT;
 
77
 
 
78
VAR I,J:LONGINT;
 
79
 
 
80
BEGIN
 
81
   I:=Length(S);
 
82
   IF I=0 THEN
 
83
    J:=0
 
84
   ELSE
 
85
    BEGIN
 
86
   J:=Count;
 
87
   IF J>I THEN
 
88
    BEGIN
 
89
     NextCharPosSet:=0;
 
90
     EXIT;
 
91
    END;
 
92
   WHILE (j<=i) AND (NOT (S[J] IN C)) DO INC(J);
 
93
   IF (J>I) THEN
 
94
    J:=0;                                        // NOT found.
 
95
   END;
 
96
 NextCharPosSet:=J;
 
97
END;
 
98
 
 
99
 
 
100
PROCEDURE RTrim(VAR P : String;Ch:Char);
 
101
 
 
102
VAR I,J : LONGINT;
 
103
 
 
104
BEGIN
 
105
 I:=ORD(P[0]);      { Keeping length in local data eases optimalisations}
 
106
 IF (I>0) THEN
 
107
  BEGIN
 
108
   J:=I;
 
109
   WHILE (P[J]=Ch) AND (J>0) DO DEC(J);
 
110
   IF J<>I THEN
 
111
    Delete(P,J+1,I-J+1);
 
112
   END;
 
113
END;
 
114
 
 
115
PROCEDURE UpperCase(VAR S : String);
 
116
 
 
117
VAR L,I : LONGINT;
 
118
 
 
119
BEGIN
 
120
 L:=Length(S);
 
121
 IF L>0 THEN
 
122
  FOR I:=1 TO L DO
 
123
   IF (S[I]>CHR(96)) AND (S[I]<CHR(123)) THEN
 
124
    S[I]:=CHR(ORD(S[I])-32);
 
125
END;
 
126
 
 
127
PROCEDURE LTrim(VAR P : String;Ch:Char);
 
128
 
 
129
VAR I,J : LONGINT;
 
130
 
 
131
BEGIN
 
132
 I:=ORD(P[0]);      { Keeping length in local data eases optimalisations}
 
133
 IF (I>0) THEN
 
134
  BEGIN
 
135
   J:=1;
 
136
   WHILE (P[J]=Ch) AND (J<=I) DO INC(J);
 
137
   IF J>1 THEN
 
138
    Delete(P,1,J-1);
 
139
   END;
 
140
END;
 
141
 
 
142
 
 
143
{*****************************************************************************
 
144
                              Parsing helpers
 
145
*****************************************************************************}
 
146
 
 
147
FUNCTION XlatString(Var S : String):BOOLEAN;
 
148
{replaces \xxx in string S with #x, and \\ with \ (escaped)
 
149
 which can reduce size of string.
 
150
 
 
151
Returns false when an error in the line exists}
 
152
 
 
153
 
 
154
Function GetNumber(Position:LONGINT):LONGINT;
 
155
 
 
156
VAR C,
 
157
    Value,
 
158
    I : LONGINT;
 
159
 
 
160
BEGIN
 
161
 I:=0; Value:=0;
 
162
 WHILE I<3 DO
 
163
  BEGIN
 
164
   C:=ORD(S[Position+I]);
 
165
   IF (C>47) AND (C<56) THEN
 
166
    C:=C-48
 
167
   ELSE
 
168
    BEGIN
 
169
     GetNumber:=-1;
 
170
     EXIT;
 
171
    END;
 
172
   IF I=0 THEN
 
173
    C:=C SHL 6;
 
174
   IF I=1 THEN
 
175
    C:=C SHL 3;
 
176
   Value:=Value + C;
 
177
   INC(I);
 
178
   END;
 
179
 GetNumber:=Value;
 
180
END;
 
181
 
 
182
VAR S2:String;
 
183
    A,B : LONGINT;
 
184
    Value : LONGINT;
 
185
 
 
186
BEGIN
 
187
 A:=1; B:=1;
 
188
 WHILE A<=Length(S) DO
 
189
  BEGIN
 
190
   IF S[A]='\' THEN
 
191
    IF S[A+1]='\' THEN
 
192
     BEGIN
 
193
      S2[B]:='\';
 
194
      INC (A,2); INC(B);
 
195
     END
 
196
    ELSE
 
197
     BEGIN
 
198
      Value:=GetNumber(A+1);
 
199
      IF Value=-1 THEN
 
200
       BEGIN
 
201
        XlatString:=FALSE;
 
202
        EXIT;
 
203
       END;
 
204
      S2[B]:=CHR(Value);
 
205
      INC(B); INC(A,4);
 
206
     END
 
207
   ELSE
 
208
    BEGIN
 
209
     S2[B]:=S[A];
 
210
     INC (A);
 
211
     INC (B);
 
212
    END;
 
213
  END;
 
214
 S2[0]:=CHR(B-1);
 
215
 S:=S2;
 
216
 XlatString:=TRUE;
 
217
END;
 
218
 
 
219
{Global equates}
 
220
 
 
221
VAR
 
222
  Inname,                     { Name of input file }
 
223
  OutName,                    { Name of output (.inc) file }
 
224
  BinConstName : string;      { (-b only) commandline name of constant }
 
225
  OutputMode   : TOutputMode; { Output mode (char,byte,string) }
 
226
  I_Binary     : BOOLEAN;     { TRUE is binary input, FALSE textual }
 
227
  MsgTxt       : pchar;       { Temporary storage of data }
 
228
  msgsize      : longint;     { Bytes used in MsgTxt }
 
229
  C            : CHAR;
 
230
 
 
231
 
 
232
{*****************************************************************************
 
233
                               WriteCharFile
 
234
*****************************************************************************}
 
235
 
 
236
{Dump the contents of MsgTxt (msgsize bytes) to file T (which has been opened),
 
237
using CONSTNAME as the name of the ARRAY OF CHAR constant}
 
238
procedure WriteCharFile(var t:text;constname:string);
 
239
 
 
240
  function createconst(b:byte):string;
 
241
  {decides whether to use the #xxx code or 'c' style for each char}
 
242
  begin
 
243
    if (b in [32..127]) and (b<>39) then
 
244
     createconst:=''''+chr(b)+''''
 
245
    else
 
246
     createconst:='#'+chr(b div 100+48)+chr((b mod 100) div 10+48)+chr(b mod 10+48)
 
247
  end;
 
248
 
 
249
var
 
250
  cidx,i  : longint;
 
251
  p       : PCHAR;
 
252
begin
 
253
  Writeln('Writing constant: ',constname,' to file '#39,outname,#39);
 
254
{Open textfile}
 
255
  write(t,'const ',constname,' : array[0..'); Writeln(t,msgsize-1,'] of char=(');
 
256
  p:=msgtxt;
 
257
  cidx:=0;
 
258
  for i:=0 to msgsize-1 do
 
259
   begin
 
260
     if cidx=15 then
 
261
      begin
 
262
        if cidx>0 then
 
263
         writeln(t,',')
 
264
        else
 
265
         writeln(t,'');
 
266
        write(t,'  ');
 
267
        cidx:=0;
 
268
      end
 
269
     else
 
270
       IF cidx>0 THEN
 
271
        write(t,',')
 
272
       ELSE
 
273
        Write(T,'  ');
 
274
     write(t,createconst(ord(p^)));
 
275
     inc(cidx);
 
276
     inc(p);
 
277
   end;
 
278
  writeln(t,');');
 
279
  Writeln(T);
 
280
end;
 
281
 
 
282
 
 
283
{*****************************************************************************
 
284
                               WriteByteFile
 
285
*****************************************************************************}
 
286
 
 
287
{Dump the contents of MsgTxt (msgsize bytes) to file T (which has been opened),
 
288
using CONSTNAME as the name of the ARRAY OF BYTE constant}
 
289
procedure WriteByteFile(var t:text;constname:string);
 
290
 
 
291
  function createconst(b:byte):string;
 
292
  {Translates byte B to a $xx hex constant}
 
293
  VAR l : Byte;
 
294
  begin
 
295
   createconst[1]:='$'; createconst[0]:=#3;
 
296
   l:=ORD(B SHR 4) +48;
 
297
   IF l>57 THEN
 
298
    l:=L+7;
 
299
   createconst[2]:=CHR(l);
 
300
   l:=ORD(B and 15) +48;
 
301
   IF l>57 THEN
 
302
    INC(L,7);
 
303
   createconst[3]:=CHR(l);
 
304
  end;
 
305
 
 
306
var
 
307
  cidx,i  : longint;
 
308
  p       : pchar;
 
309
begin
 
310
  Writeln('Writing constant: ',constname,' to file '#39,outname,#39);
 
311
{Open textfile}
 
312
  write(t,'const ',constname,' : array[0..'); Writeln(t,msgsize-1,'] of byte=(');
 
313
  p:=msgtxt;
 
314
  cidx:=0;
 
315
  for i:=0 to msgsize-1 do
 
316
   begin
 
317
     if cidx=15 then
 
318
      begin
 
319
        if cidx>0 then
 
320
         writeln(t,',')
 
321
        else
 
322
         writeln(t,'');
 
323
        write(t,'  ');
 
324
        cidx:=0;
 
325
      end
 
326
     else
 
327
       IF cidx>0 THEN
 
328
        write(t,',')
 
329
       ELSE
 
330
        Write(T,'  ');
 
331
     write(t,createconst(ord(p^)));
 
332
     inc(cidx);
 
333
     inc(p);
 
334
   end;
 
335
  writeln(t,');');
 
336
  Writeln(T);
 
337
end;
 
338
 
 
339
 
 
340
{*****************************************************************************
 
341
                               WriteStringFile
 
342
*****************************************************************************}
 
343
 
 
344
procedure WriteStringFile(var t:text;constname:string);
 
345
const
 
346
  maxslen=240; { to overcome aligning problems }
 
347
 
 
348
  function l0(l:longint):string;
 
349
  var
 
350
    s : string[16];
 
351
  begin
 
352
    str(l,s);
 
353
    while (length(s)<5) do
 
354
     s:='0'+s;
 
355
    l0:=s;
 
356
  end;
 
357
 
 
358
var
 
359
  slen,
 
360
  len,i  : longint;
 
361
  p      : pchar;
 
362
  start,
 
363
  quote  : boolean;
 
364
begin
 
365
  Writeln('Writing constant: ',constname,' to file '#39,outname,#39);
 
366
{Open textfile}
 
367
  writeln(t,'{$ifdef Delphi}');
 
368
  writeln(t,'const '+constname+' : array[0..',(msgsize-1) div maxslen,'] of string[',maxslen,']=(');
 
369
  writeln(t,'{$else Delphi}');
 
370
  writeln(t,'const '+constname+' : array[0..',(msgsize-1) div maxslen,',1..',maxslen,'] of char=(');
 
371
  write(t,'{$endif Delphi}');
 
372
{Parse buffer in msgbuf and create indexs}
 
373
  p:=msgtxt;
 
374
  slen:=0;
 
375
  len:=0;
 
376
  quote:=false;
 
377
  start:=true;
 
378
  for i:=1 to msgsize do
 
379
   begin
 
380
     if slen>=maxslen then
 
381
      begin
 
382
        if quote then
 
383
         begin
 
384
           write(t,'''');
 
385
           quote:=false;
 
386
         end;
 
387
        write(t,',');
 
388
        slen:=0;
 
389
        inc(len);
 
390
      end;
 
391
     if (len>70) or (start) then
 
392
      begin
 
393
        if quote then
 
394
         begin
 
395
           write(t,'''');
 
396
           quote:=false;
 
397
         end;
 
398
        if slen>0 then
 
399
          writeln(t,'+')
 
400
        else
 
401
          writeln(t);
 
402
        len:=0;
 
403
        start:=false;
 
404
      end;
 
405
     if (len=0) then
 
406
      write(t,'  ');
 
407
     if (ord(p^)>=32) and (p^<>#39) then
 
408
      begin
 
409
        if not quote then
 
410
         begin
 
411
           write(t,'''');
 
412
           quote:=true;
 
413
           inc(len);
 
414
         end;
 
415
        write(t,p^);
 
416
        inc(len);
 
417
      end
 
418
     else
 
419
      begin
 
420
        if quote then
 
421
         begin
 
422
           write(t,'''');
 
423
           inc(len);
 
424
           quote:=false;
 
425
         end;
 
426
        write(t,'#'+chr(ord(p^) div 100+48)+chr((ord(p^) mod 100) div 10+48)+chr(ord(p^) mod 10+48));
 
427
        inc(len,3);
 
428
      end;
 
429
     { start a new line when a #0 or #10 is found }
 
430
     if p^ in [#0,#10] then
 
431
      start:=true;
 
432
     inc(slen);
 
433
     inc(p);
 
434
   end;
 
435
  if quote then
 
436
   write(t,'''');
 
437
  writeln(t,'');
 
438
  writeln(t,');');
 
439
end;
 
440
 
 
441
 
 
442
{*****************************************************************************
 
443
                                   Parser
 
444
*****************************************************************************}
 
445
 
 
446
FUNCTION SpecialItem(S : String):LONGINT;
 
447
{ This procedure finds the next comma, (or the end of the string)
 
448
    but comma's within single or double quotes should be ignored.
 
449
    Single quotes within double quotes and vice versa are also ignored.}
 
450
 
 
451
VAR DataItem : LONGINT;
 
452
 
 
453
CONST xFcl : CHARSET = [',',#39,'"'];
 
454
 
 
455
BEGIN
 
456
 
 
457
    DataItem:=0;
 
458
    REPEAT
 
459
     DataItem:=NextCharPosSet(S,xFcl,DataItem+1);   {Find first " ' or ,}
 
460
      IF (DataItem<>0) AND ((S[DataItem]='"') OR (S[DataItem]=#39)) THEN { (double)Quote found?}
 
461
       DataItem:=NextCharPos(S,S[DataItem],DataItem+1);  { then find other one}
 
462
     UNTIL (DataItem=0) OR (S[DataItem]=',');
 
463
     IF DataItem=0 THEN     {Last data field of this line?}
 
464
      DataItem:=Length(S);
 
465
    SpecialItem:=DataItem;
 
466
END;
 
467
 
 
468
 
 
469
{ Handles reading and processing of a textual file}
 
470
procedure DoFile;
 
471
var
 
472
  Infile,
 
473
  Outfile : text;       {in and output textfiles}
 
474
  line, DataItem,       {line number, position in DATA line}
 
475
  I1,I2,                {4 temporary counters}
 
476
  I3,I4  : longint;
 
477
  s,S1    : string;     {S is string after reading, S1 is temporary string or
 
478
                          current DATA-item being processed }
 
479
  VarName : String;     { Variable name of constant to be written}
 
480
 
 
481
  PROCEDURE ParseError;
 
482
  {Extremely simple errorhandler}
 
483
  BEGIN
 
484
   Writeln('Error in line : ',Line, ' Somewhere near :',#39,S1,#39);
 
485
   Close(InfIle); Close(Outfile);
 
486
   HALT;
 
487
  END;
 
488
 
 
489
  PROCEDURE FixDec;
 
490
  { Reads decimal value starting at S1[1].
 
491
       Value in I3, number of digits found in I1}
 
492
       var I1,I2,i3 : longint;
 
493
 
 
494
  BEGIN
 
495
   I1:=1;
 
496
   WHILE ((S1[I1]>#47) AND (S1[I1]<#58)) AND (I1<=Length(S1)) DO
 
497
    INC(I1);
 
498
   DEC(I1);
 
499
   IF I1=0 THEN
 
500
    ParseError;
 
501
   I3:=0;
 
502
   FOR I2:=1 TO I1 DO
 
503
    I3:=(I3*10)+ ORD(S1[I2])-48;
 
504
  {Calc no of bytes(1,2 or 4) required from no of digits found}
 
505
   IF (I1<3) THEN
 
506
    I2:=1
 
507
   ELSE
 
508
    IF (I1=3) AND (I3<256) THEN
 
509
     I2:=1
 
510
    ELSE
 
511
     BEGIN
 
512
      IF I1<5 THEN
 
513
       I2:=2
 
514
       ELSE
 
515
        IF (I1=5) AND (i3<65536) THEN
 
516
         I2:=2
 
517
        ELSE
 
518
         I2:=4;
 
519
     END;
 
520
  END;
 
521
 
 
522
  PROCEDURE DoChar;
 
523
  { Reads a #xxx constant at S1[1], and puts it in msgtxt array.
 
524
      Deletes #xxx constant from S1}
 
525
  BEGIN
 
526
   Delete(S1,1,1);
 
527
   FixDec;
 
528
   msgtxt[Msgsize]:=CHR(I3);
 
529
   inc(msgsize);
 
530
   Delete(S1,1,I1);
 
531
  END;
 
532
 
 
533
  PROCEDURE DoQuote;
 
534
  { Reads a quoted text-string ('xxx' or "xxx"). Quotechar is in S1[1]
 
535
    (always ' or "), any char except the quotechar is allowed between two
 
536
    quotechars.
 
537
      Deletes quoted textstring incl quotes from S1}
 
538
  VAR
 
539
    C : Char;
 
540
  BEGIN
 
541
    C:=S1[1];
 
542
    Delete(S1,1,1);
 
543
    I1:=Pos(C,S1);                       {Find other quote}
 
544
    IF I1=0 THEN
 
545
     ParseError;                    {Quotes have to be matched}
 
546
    Dec(I1);
 
547
    IF I1<>0 THEN
 
548
     BEGIN
 
549
      Move(S1[1],Msgtxt[Msgsize],I1);
 
550
      INC(msgsize,I1);
 
551
     END;
 
552
    Delete(S1,1,I1+1);
 
553
    LTrim(S1,' ');
 
554
  END;
 
555
 
 
556
  PROCEDURE FixHex(base2:LONGINT);
 
557
  { Reads a base 2,8 or 16 constant from S1.
 
558
    Parameter = 2Log of base (1,3 or 4 corresponding to base 2,8 and 16)
 
559
    Constant is processed, the number of digits estimated (1,2 or 4 bytes) and
 
560
    the value is appended to msgtxt accordingly}
 
561
  BEGIN
 
562
    I3:=0;
 
563
    I2:=1;
 
564
    WHILE (S1[I2] IN ['0'..'9','A'..'F','a'..'f']) AND (I2<=Length(S1)) DO
 
565
     BEGIN
 
566
      IF (S1[I2]>#47) AND (S1[I2]<#58) THEN
 
567
       I3:=(I3 SHL base2)+ ORD(S1[I2])-48
 
568
      ELSE
 
569
       IF (S1[I2]>#64) AND (S1[I2]<#71) THEN
 
570
        I3:=(I3 SHL base2)+ ORD(S1[I2])-55
 
571
       ELSE
 
572
        IF (S1[I2]>#96) AND (S1[I2]<#103) THEN
 
573
         I3:=(I3 SHL base2)+ ORD(S1[I2])-87
 
574
       ELSE
 
575
        ParseError;
 
576
       INC(I2);
 
577
     END;
 
578
    DEC(I2);
 
579
    CASE Base2 OF
 
580
     4 :   BEGIN
 
581
           I4:=(I2 SHR 1);
 
582
           IF ODD(I2) THEN
 
583
            INC(I4);
 
584
           IF I4=3 THEN I4:=4
 
585
          END;
 
586
     3 :   I4:=(I2*3 DIV 8)+1;
 
587
     1 :   BEGIN
 
588
            IF I2<9 THEN
 
589
             I4:=1
 
590
            ELSE
 
591
             IF I2<17 THEN
 
592
              I4:=2
 
593
             ELSE
 
594
             I4:=4;
 
595
           END;
 
596
      ELSE
 
597
       BEGIN
 
598
        Writeln(' severe internal error ');
 
599
        ParseError;
 
600
       END; {else}
 
601
    END; {Case}
 
602
    move(I3,msgtxt[Msgsize],i4);
 
603
    inc(msgsize,i4);
 
604
  END;
 
605
 
 
606
  PROCEDURE DoTextual;
 
607
  { processes aggregates of textual data like 'xxx'+#39"2143124"+'1234'#123}
 
608
 
 
609
  BEGIN
 
610
   REPEAT
 
611
    CASE S1[1] OF
 
612
     '#' : DoChar;
 
613
     '"',#39 : DoQuote;           {Should I support octal codes here?}
 
614
    ELSE
 
615
     ParseError;
 
616
     END;
 
617
    LTrim(S1,' ');
 
618
    IF (S1[1]='+') THEN
 
619
     Delete(S1,1,1);
 
620
    LTrim(S1,' ');
 
621
   UNTIL Length(S1)=0;
 
622
  END;
 
623
 
 
624
  PROCEDURE FlushMsgTxt;            {Flush MsgTxt array}
 
625
  BEGIN
 
626
   IF msgsize>0 THEN          {In memory? Then flush}
 
627
    BEGIN
 
628
      case outputmode of
 
629
        OutByte :
 
630
          WriteByteFile(outfile,Varname);
 
631
        OutChar :
 
632
          WriteCharFile(outfile,varname);
 
633
        OutString :
 
634
          WriteStringFile(outfile,varname);
 
635
      end;
 
636
     msgsize:=0;
 
637
    END;
 
638
  END;
 
639
 
 
640
{Actual DoFile}
 
641
begin
 
642
  Getmem(msgtxt,maxbufsize);
 
643
  Writeln('processing file : ',inname);
 
644
{Read the message file}
 
645
  assign(infile,inname);
 
646
  {$I-}
 
647
   reset(infile);
 
648
  {$I+}
 
649
  if ioresult<>0 then
 
650
   begin
 
651
     WriteLn('file '+inname+' not found');
 
652
     exit;
 
653
   end;
 
654
{Create output file}
 
655
  assign (outfile,outname);
 
656
  rewrite(outfile);
 
657
  msgsize:=0;
 
658
  Line:=0;
 
659
  while not eof(infile) do
 
660
   begin
 
661
    readln(infile,s);      {Read a line}
 
662
    INC(Line);
 
663
    S1:=Copy(S,1,5);
 
664
    Uppercase(S1);
 
665
    IF S1='DATA ' THEN   {DATA keyword?}
 
666
     BEGIN
 
667
      Delete(S,1,5);
 
668
      REPEAT
 
669
       DataItem:=SpecialItem(S);  {Yes. Determine size of DATA field.}
 
670
       IF DataItem<>0 THEN
 
671
        BEGIN
 
672
         I1:=DataItem;
 
673
         IF DataItem=Length(S) THEN
 
674
          INC(i1);        {DataItem fix for last field}
 
675
         S1:=Copy(S,1,I1-1);    { copy field to S1}
 
676
         Delete(S,1,I1);        {Delete field from S}
 
677
         LTrim(S1,' ');
 
678
         RTrim(S1,' ');
 
679
         LTrim(S,' ');
 
680
         CASE S1[1] OF        {Select field type}
 
681
          #39,'"','#' : DoTextual; { handles textual aggregates
 
682
                                     e.g. #124"142"#123'sdgf''ads'}
 
683
          '$' : BEGIN         {Handle $xxxx hex codes}
 
684
                 Delete(S1,1,1);
 
685
                 RTrim(S1,' ');
 
686
                 IF Length(S1)>0 THEN
 
687
                  FixHex(4)
 
688
                 ELSE
 
689
                  ParseError;
 
690
                 END;
 
691
    '0'..'9'  : BEGIN    { handles 0x124,124124,124124H,234h,666o,353d,24b}
 
692
                 IF (Length(S1)>1) AND (S1[2]='x') THEN {C style 0xABCD hex}
 
693
                  BEGIN
 
694
                   Delete(S1,1,2);
 
695
                   FixHex(4);
 
696
                  END
 
697
                 ELSE {other types (HP notation suffix h,o,d and b (and upcase versions,
 
698
                                                       and no suffix) }
 
699
                  BEGIN
 
700
                   CASE S1[Length(S1)] OF
 
701
                    'H','h' : FixHex(4);      {Hex}
 
702
                    'o','O' : FixHex(3);      {octal}
 
703
                        'B','b' : BEGIN       {Binary}
 
704
                                   DEC(S1[0]); {avoid 'b' char being treated as
 
705
                                                 hex B }
 
706
                                   FixHex(1);
 
707
                                  END;
 
708
               '0'..'9','d','D' : BEGIN      {decimal versions}
 
709
                                   FixDec;   {Fixdec is safe for trailing chars}
 
710
                                   {I1 =no of digits, I3=value, I2= no bytes needed}
 
711
                                   move(I3,msgtxt[Msgsize],i2);
 
712
                                   inc(msgsize,i2)
 
713
                                  END
 
714
                             ELSE
 
715
                              ParseError; {otherwise wrong suffix}
 
716
                           END {Nested case}
 
717
                       END; { IF S1[2]='x'}
 
718
                      END; { '0'..'9'}
 
719
              '%'   : BEGIN          {%101010 binary constants}
 
720
                       Delete(S1,1,1);
 
721
                       FixHex(1);
 
722
                      END;
 
723
              '\'   : BEGIN          {\xxx octal constants}
 
724
                       Delete(S1,1,1);
 
725
                       FixHex(3);
 
726
                      END;
 
727
          END; {Case}
 
728
         END; {IF <>0}
 
729
        UNTIL {(DataItem:=Length(S)) OR} (DataItem=0); {parse until String is empty}
 
730
      END {S1='DATA'}
 
731
     ELSE
 
732
      BEGIN                          {Non DATA line}
 
733
       IF (Length(S)<>0) AND NOT (S[1] IN ['#',';','%']) THEN
 
734
        BEGIN
 
735
         C:=S[1];
 
736
         IF NOT XlatString(S) THEN  {Expand \xxx octal constants}
 
737
          BEGIN
 
738
           Writeln('Some error with a \xxx constant or a stale (unescaped) backslash');
 
739
           ParseError;
 
740
          END;
 
741
         IF C='!' THEN         { New variable}
 
742
          BEGIN
 
743
           FlushMsgTxt;
 
744
           I1:=1;
 
745
           OutputMode:=OutChar;
 
746
           IF S[2]='$' THEN      {Flag for ARRAY OF BYTE?}
 
747
            BEGIN
 
748
             INC(I1);
 
749
             OutputMode:=OutByte;
 
750
            END;
 
751
           Delete(S,1,I1);
 
752
           VarName:=S;
 
753
          END
 
754
         ELSE
 
755
          BEGIN {Normal line}
 
756
           i1:=Length(S);
 
757
           move(s[1],msgtxt[Msgsize],i1);
 
758
           inc(msgsize,i1);
 
759
          END;
 
760
      END;
 
761
    END;
 
762
   end;
 
763
  close(infile);
 
764
  FlushMsgTxt;                    {Flush variable if msgtxt is occupied}
 
765
  Close(Outfile);
 
766
end;
 
767
 
 
768
 
 
769
{*****************************************************************************
 
770
                                    Binary File
 
771
*****************************************************************************}
 
772
 
 
773
procedure DoBinary;
 
774
var
 
775
  Infile  : File;
 
776
  Outfile : text;
 
777
  i       : longint;
 
778
begin
 
779
  Writeln('processing file : ',inname);
 
780
{ Read the file }
 
781
  assign(infile,inname);
 
782
  {$I-}
 
783
   reset(infile,1);
 
784
  {$I+}
 
785
  if ioresult<>0 then
 
786
   begin
 
787
     WriteLn('file '+inname+' not found');
 
788
     exit;
 
789
   end;
 
790
{ First parse the file and count bytes needed }
 
791
  msgsize:=FileSize(InFile);
 
792
  Getmem(msgtxt,msgsize);
 
793
  BlockRead(InFile,msgTxt[0],msgsize,i);
 
794
  close(infile);
 
795
  IF I<>msgsize THEN
 
796
   BEGIN
 
797
     Writeln('Error while reading file',inName);
 
798
     HALT(1);
 
799
   END;
 
800
{ Output }
 
801
  assign (outfile,outname);
 
802
  rewrite(outfile);
 
803
  case outputmode of
 
804
    OutByte :
 
805
      WriteByteFile(outfile,BinconstName);
 
806
    OutChar :
 
807
      WriteCharFile(outfile,BinconstName);
 
808
    OutString :
 
809
      WriteStringFile(outfile,BinconstName);
 
810
  end;
 
811
  Close(Outfile);
 
812
end;
 
813
 
 
814
 
 
815
{*****************************************************************************
 
816
                                Main Program
 
817
*****************************************************************************}
 
818
 
 
819
procedure getpara;
 
820
var
 
821
  ch      : char;
 
822
  para    : string;
 
823
  files,i : word;
 
824
 
 
825
  procedure helpscreen;
 
826
  begin
 
827
    writeln('usage : data2inc [Options] <msgfile> [incfile] [constname]');
 
828
    Writeln('  The constname parameter is only valid in combination');
 
829
    writeln('  with -b, otherwise the constname must be specified in the inputfile');
 
830
    Writeln;
 
831
    writeln('<Options> can be :');
 
832
    writeln('              -B     File to read is binary.');
 
833
    writeln('              -A     array of byte output (default is array of char)');
 
834
    writeln('              -S     array of string output');
 
835
    writeln('              -V     Show version');
 
836
    writeln('        -? or -H     This HelpScreen');
 
837
    writeln;
 
838
    Writeln(' See data2inc.exm for a demonstration source');
 
839
    halt(1);
 
840
  end;
 
841
 
 
842
 
 
843
begin
 
844
  I_binary:=FALSE;
 
845
  OutputMode:=OutChar;
 
846
  FIles:=0;
 
847
  for i:=1to paramcount do
 
848
   begin
 
849
     para:=paramstr(i);
 
850
     if (para[1]='-') then
 
851
      begin
 
852
        ch:=upcase(para[2]);
 
853
        delete(para,1,2);
 
854
        case ch of
 
855
         'B' : I_Binary:=TRUE;
 
856
         'A' : OutputMode:=OutByte;
 
857
         'S' : OutputMode:=OutString;
 
858
         'V' : begin
 
859
                 Writeln('Data2Inc ',version,' (C) 1999 Peter Vreman and Marco van de Voort');
 
860
                 Writeln;
 
861
                 Halt;
 
862
               end;
 
863
     '?','H' : Helpscreen;
 
864
 
 
865
        end;
 
866
     end
 
867
    else
 
868
     begin
 
869
       inc(Files);
 
870
       if Files>3 then
 
871
        HelpScreen;
 
872
       case Files of
 
873
        1 : InName:=Para;
 
874
        2 : OutName:=Para;
 
875
        3 : BinConstName:=Para;
 
876
       end;
 
877
     end;
 
878
    END;
 
879
   if (FIles<3) AND I_Binary then
 
880
     HelpScreen;
 
881
   IF Files<2 THEN
 
882
    HelpScreen;
 
883
end;
 
884
 
 
885
begin
 
886
  GetPara;
 
887
  IF I_Binary THEN
 
888
   DoBinary
 
889
  ELSE
 
890
   DoFile;
 
891
end.