← Back to branch summary

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

« back to all changes in this revision

Viewing changes to utils/fprcp/fprcp.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:
utils/fprcp/fprcp.pp
1
 
program FreePasResourcePreprocessor;
2
 
{$ifdef win32}
3
 
{$APPTYPE CONSOLE}
4
 
{$endif}
5
 
{$ifndef fpc}{$N+}{$endif}
6
 
uses
7
 
 Comments,PasPrep,Expr
8
 
{$ifndef win32}
9
 
,DOS;
10
 
type
11
 
 str255=string[255];
12
 
{$else}
13
 
;
14
 
type
15
 
 str255=string[255];
16
 
function SearchPath(path,name,ext:pchar;size:longint;buf:pchar;var x:pointer):longint;stdcall;
17
 
 external 'kernel32.dll' name 'SearchPathA';
18
 
function FSearch(s,path:str255):Str255;
19
 
 var
20
 
  l:longint;
21
 
 procedure zeroterm(var s:str255);
22
 
  begin
23
 
   l:=length(s);
24
 
   move(s[1],s[0],l);
25
 
   s[l]:=#0;
26
 
  end;
27
 
 var
28
 
  buf:str255;
29
 
  aPtr:pointer;
30
 
  i:longint;
31
 
 begin
32
 
  zeroterm(path);
33
 
  zeroterm(s);
34
 
  i:=SearchPath(pchar(@path),pchar(@s),nil,255,pchar(@buf[1]),aPtr);
35
 
  if i<=255 then
36
 
   byte(buf[0]):=i
37
 
  else
38
 
   buf[0]:=#0;
39
 
  FSearch:=buf;
40
 
 end;
41
 
{$endif}
42
 
 
43
 
type
44
 
 pstring=^str255;
45
 
 PReplaceRec=^TReplaceRec;
46
 
 TReplaceRec=record
47
 
  next:PReplaceRec;
48
 
  CaseSentitive:longbool;
49
 
  oldvalue,newvalue:pstring;
50
 
 end;
51
 
 chars=array[1..2]of char;
52
 
 pchars=^chars;
53
 
const
54
 
 Chain:PReplaceRec=nil;
55
 
 ChainHdr:PReplaceRec=nil;
56
 
 Chainlen:longint=0;
57
 
var
58
 
 f:file;
59
 
 s:str255;
60
 
 size,nextpos:longint;
61
 
 buf:pchars;
62
 
 i:longint;
63
 
function Entry(buf:pchars;Size,fromPos:longint;const sample:str255;casesent:longbool):longbool;
64
 
 var
65
 
  i:longint;
66
 
  c:char;
67
 
 begin
68
 
  Entry:=false;
69
 
  if(fromPos>1)and(buf^[pred(frompos)]>#32)then
70
 
   exit;
71
 
  if fromPos+length(sample)-1>=size then
72
 
   exit;
73
 
  if buf^[fromPos+length(sample)]>#32 then
74
 
   exit;
75
 
  Entry:=true;
76
 
  for i:=1 to length(sample)do
77
 
   begin
78
 
    if pred(fromPos+i)>size then
79
 
     begin
80
 
      Entry:=false;
81
 
      exit;
82
 
     end;
83
 
    c:=buf^[pred(fromPos+i)];
84
 
    if not casesent then
85
 
     c:=UpCase(c);
86
 
    if c<>sample[i]then
87
 
     begin
88
 
      Entry:=false;
89
 
      exit;
90
 
     end;
91
 
    end;
92
 
 end;
93
 
function GetWord(buf:pchars;Size,fromPos:longint;var EndPos:longint):str255;
94
 
 var
95
 
  s:str255;
96
 
  i:longint;
97
 
  word_begin:longbool;
98
 
 begin
99
 
  s:='';
100
 
  i:=frompos;
101
 
  word_begin:=false;
102
 
  while i<size do
103
 
   begin
104
 
    if not word_begin then
105
 
     word_begin:=(buf^[i]>#32)and(buf^[i]<>';')and(buf^[i]<>'=');
106
 
    if word_begin then
107
 
     begin
108
 
      if not(buf^[i]in[#0..#32,';','='])then
109
 
       s:=s+buf^[i]
110
 
      else
111
 
       begin
112
 
        EndPos:=i;
113
 
        break;
114
 
       end;
115
 
     end;
116
 
    inc(i);
117
 
   end;
118
 
  GetWord:=s;
119
 
 end;
120
 
procedure excludeComments(buf:pchars;size:longint);
121
 
 var
122
 
  comment:longbool;
123
 
  i:longint;
124
 
 begin
125
 
  comment:=false;
126
 
  for i:=1 to pred(size)do
127
 
   begin
128
 
    if(buf^[i]='/')and(buf^[succ(i)]='*')then
129
 
     comment:=true;
130
 
    if comment then
131
 
     begin
132
 
      if(buf^[i]='*')and(buf^[succ(i)]='/')then
133
 
       begin
134
 
        comment:=false;
135
 
        buf^[succ(i)]:=' ';
136
 
       end;
137
 
      buf^[i]:=' ';
138
 
     end;
139
 
   end;
140
 
  comment:=false;
141
 
  for i:=1 to pred(size)do
142
 
   begin
143
 
    if(buf^[i]='/')and(buf^[succ(i)]='/')then
144
 
     comment:=true;
145
 
    if comment then
146
 
     begin
147
 
      if buf^[i]in[#10,#13]then
148
 
       comment:=false;
149
 
      buf^[i]:=' ';
150
 
     end;
151
 
   end;
152
 
 end;
153
 
function IsSwitch(const switch:str255):longbool;
154
 
 var
155
 
  i:longint;
156
 
 begin
157
 
  IsSwitch:=false;
158
 
  for i:=1 to ParamCount do
159
 
   if paramstr(i)='-'+switch then
160
 
    begin
161
 
     IsSwitch:=true;
162
 
     exit;
163
 
    end;
164
 
 end;
165
 
function GetSwitch(const switch:str255):str255;
166
 
 var
167
 
  i:longint;
168
 
 begin
169
 
  GetSwitch:='';
170
 
  for i:=1 to paramcount do
171
 
   if paramstr(i)='-'+switch then
172
 
    GetSwitch:=paramstr(succ(i));
173
 
 end;
174
 
procedure saveproc(const key,value:str255;CaseSent:longbool);{$ifndef fpc}far;{$endif}
175
 
 var
176
 
  c:pReplaceRec;
177
 
 begin
178
 
  new(c);
179
 
  c^.next:=nil;
180
 
  c^.CaseSentitive:=CaseSent;
181
 
  getmem(c^.oldvalue,succ(length(key)));
182
 
  c^.oldvalue^:=key;
183
 
  getmem(c^.newvalue,succ(length(value)));
184
 
  c^.newvalue^:=value;
185
 
  if chainhdr=nil then
186
 
   begin
187
 
    chain:=c;
188
 
    chainhdr:=chain;
189
 
    ChainLen:=1;
190
 
   end
191
 
  else
192
 
   begin
193
 
    chain^.next:=c;
194
 
    chain:=c;
195
 
    inc(ChainLen);
196
 
   end;
197
 
 end;
198
 
type
199
 
 Tlanguage=(L_C,L_Pascal);
200
 
function Language(s:str255):tLanguage;
201
 
 var
202
 
  s1,Lstr:str255;
203
 
  i,j:longint;
204
 
  found:longbool;
205
 
 type
206
 
  TLD=record
207
 
   x:string[3];
208
 
   l:tLanguage;
209
 
  end;
210
 
 const
211
 
  default:array[1..7]of TLD=(
212
 
   (x:'PAS';l:L_PASCAL),
213
 
   (x:'PP';l:L_PASCAL),
214
 
   (x:'P';l:L_PASCAL),
215
 
   (x:'DPR';l:L_PASCAL),
216
 
   (x:'IN?';l:L_PASCAL),
217
 
   (x:'C';l:L_C),
218
 
   (x:'H';l:L_C));
219
 
 begin
220
 
  Lstr:=GetSwitch('l');
221
 
  if lstr=''then
222
 
   Lstr:=GetSwitch('-language');
223
 
  for i:=1 to length(Lstr)do
224
 
   Lstr[i]:=UpCase(Lstr[i]);
225
 
  if Lstr='C'then
226
 
   begin
227
 
    Language:=L_C;
228
 
    exit;
229
 
   end
230
 
  else if(Lstr='PASCAL')or(Lstr='DELPHI')then
231
 
   begin
232
 
    Language:=L_PASCAL;
233
 
    exit;
234
 
   end
235
 
  else if (Lstr<>'')then
236
 
   writeln('Warning: unknown language ',Lstr);
237
 
  s1:='';
238
 
  for i:=length(s)downto 1 do
239
 
   begin
240
 
    if s[i]='.'then
241
 
     break;
242
 
    s1:=upcase(s[i])+s1;
243
 
   end;
244
 
  for i:=1 to 7 do
245
 
   begin
246
 
    found:=true;
247
 
    for j:=1 to length(s1)do
248
 
     if s1[j]<>default[i].x[j]then
249
 
      case default[i].x[j] of
250
 
       '?':
251
 
        ;
252
 
       else
253
 
        found:=false;
254
 
      end;
255
 
     if(found)and(s1<>'')then
256
 
      begin
257
 
       Language:=default[i].l;
258
 
       exit;
259
 
      end;
260
 
    end;
261
 
  Language:=L_PASCAL;
262
 
 end;
263
 
function Up(const s:str255):str255;
264
 
 var
265
 
  n:str255;
266
 
  i:longint;
267
 
 begin
268
 
  n:=s;
269
 
  for i:=1 to length(s)do
270
 
   n[i]:=upcase(s[i]);
271
 
  Up:=n;
272
 
 end;
273
 
procedure do_C(buf:pchars;size:longint;proc:pointer);
274
 
 type
275
 
  Tpushfunc=procedure(const key,value:str255;CaseSent:longBool);
276
 
 var
277
 
  position:longint;
278
 
  charconst,stringconst:longbool;
279
 
  s,s0:str255;
280
 
  afunc:Tpushfunc absolute proc;
281
 
 procedure read(var s:str255;toEOL:longbool);
282
 
  var
283
 
   i:longint absolute position;
284
 
  function EndOfWord:longbool;
285
 
   begin
286
 
    if toEOL then
287
 
     EndOfWord:=buf^[i]in[#10,#13]
288
 
    else
289
 
     EndOfWord:=buf^[i]<=#32;
290
 
   end;
291
 
  begin
292
 
   s:='';
293
 
   if i>size then
294
 
    exit;
295
 
   while buf^[i]<=#32 do
296
 
    begin
297
 
     if i>size then
298
 
      exit;
299
 
     inc(i);
300
 
    end;
301
 
   repeat
302
 
    if i>size then
303
 
     exit;
304
 
    if not stringConst then
305
 
     if buf^[i]=''''then
306
 
      charconst:=not charconst;
307
 
    if not charConst then
308
 
     if buf^[i]='"'then
309
 
      stringconst:=not stringconst;
310
 
    if(not charconst)and(not stringconst)and EndOfWord then
311
 
     exit;
312
 
    if buf^[i]>#32 then
313
 
     s:=s+buf^[i];
314
 
    inc(i);
315
 
   until false;
316
 
  end;
317
 
 begin
318
 
  ExcludeComments(buf,size);
319
 
  position:=1;
320
 
  charconst:=false;
321
 
  stringconst:=false;
322
 
  repeat
323
 
   read(s,false);
324
 
   if Up(s)='#DEFINE' then
325
 
    begin
326
 
     read(s,false);
327
 
     read(s0,true);
328
 
     Tpushfunc(afunc)(s,s0,true);
329
 
    end;
330
 
  until position>=size;
331
 
 end;
332
 
procedure expandname(var s:str255;path:str255);
333
 
 var
334
 
  astr:str255;
335
 
 begin
336
 
  astr:=fsearch(s,path);
337
 
  if astr<>''then
338
 
   s:={$ifndef Win32}FExpand{$endif}(astr);
339
 
 end;
340
 
function do_include(name:str255):longbool;
341
 
 var
342
 
  buf:pchars;
343
 
  f:file;
344
 
  size:longint;
345
 
  s1:str255;
346
 
 procedure trim;
347
 
  begin
348
 
   delete(name,1,1);
349
 
   dec(name[0]);
350
 
  end;
351
 
 begin
352
 
  if (name[1]='"')and(name[length(name)]='"')then
353
 
   trim
354
 
  else if (name[1]='<')and(name[length(name)]='>')then
355
 
   begin
356
 
    trim;
357
 
    s1:=GetSwitch('p');
358
 
    if s1=''then
359
 
     s1:=GetSwitch('-path');
360
 
    expandname(name,s1);
361
 
   end;
362
 
  assign(f,name);
363
 
  reset(f,1);
364
 
  size:=filesize(f);
365
 
  GetMem(buf,size);
366
 
  blockread(f,buf^,size);
367
 
  close(f);
368
 
  case Language(name)of
369
 
   L_C:
370
 
    do_C(buf,size,@saveProc);
371
 
   L_PASCAL:
372
 
    do_pascal(buf,size,@saveProc);
373
 
  end;
374
 
  FreeMem(buf,size);
375
 
  do_include:=true;
376
 
 end;
377
 
function CheckRight(const s:str255;pos:longint):longbool;
378
 
 begin
379
 
  CheckRight:=true;
380
 
  if pos>length(s)then
381
 
   CheckRight:=false
382
 
  else
383
 
   CheckRight:=not(s[succ(pos)]in['a'..'z','A'..'Z','0'..'9','_']);
384
 
 end;
385
 
function CheckLeft(const s:str255;pos:longint):longbool;
386
 
 begin
387
 
  CheckLeft:=true;
388
 
  if pos>1 then
389
 
   begin
390
 
    if pos>length(s)then
391
 
     CheckLeft:=false
392
 
    else
393
 
     CheckLeft:=not(s[pred(pos)]in['a'..'z','A'..'Z','0'..'9','_']);
394
 
   end;
395
 
 end;
396
 
function Evaluate(Equation:Str255):Str255;
397
 
 var
398
 
  x:double;
399
 
  Err:integer;
400
 
 begin
401
 
  Eval(Equation,x,Err);
402
 
  if(Err=0)and(frac(x)=0)then
403
 
   str(x:1:0,Equation)
404
 
  else
405
 
   Equation:='';
406
 
  Evaluate:=Equation;
407
 
 end;
408
 
type
409
 
 taccel=array[1..100]of pReplaceRec;
410
 
var
411
 
 accel:^taccel;
412
 
 c:pReplaceRec;
413
 
 j,kk:longint;
414
 
 sss,sst:str255;
415
 
 MustBeReplaced:longbool;
416
 
begin
417
 
 if(paramcount=0)or isSwitch('h')or isSwitch('-help')or((paramcount>1)and(GetSwitch('i')=''))then
418
 
  begin
419
 
   writeln('FPC CONSTANTS EXTRACTOR for resource scripts preprocessing');
420
 
   writeln('version 0.01');
421
 
   writeln('Usage: fprcp <file_name>');
422
 
   writeln('or:');
423
 
   writeln('fprcp -i <file_name> [-n] [-C] [-l PASCAL|C] [-p <include_path>]');
424
 
   writeln('      -C type C header instead preprocessed resource script');
425
 
   writeln('      -l set programming language for include files');
426
 
   writeln('      -p set path to include files');
427
 
   writeln('      -n disable support of pascal comments nesting');
428
 
   halt;
429
 
  end;
430
 
 if ParamCount=1 then
431
 
  assign(f,paramstr(1))
432
 
 else
433
 
  assign(f,GetSwitch('i'));
434
 
 reset(f,1);
435
 
 size:=filesize(f);
436
 
 getmem(buf,size);
437
 
 blockread(f,buf^,size);
438
 
 close(f);
439
 
 if isSwitch('n')then
440
 
  PasNesting:=false;
441
 
 if isSwitch('-disable-nested-pascal-comments')then
442
 
  PasNesting:=false;
443
 
 excludeComments(buf,size);
444
 
 for i:=1 to size do
445
 
  begin
446
 
   if entry(buf,size,i,'#include',true)then
447
 
    do_include(GetWord(buf,size,i+length('#include'),nextpos));
448
 
  end;
449
 
 
450
 
 getmem(Accel,sizeof(pReplaceRec)*ChainLen);
451
 
 c:=ChainHdr;
452
 
 i:=0;
453
 
 while c<>nil do
454
 
  begin
455
 
   inc(i);
456
 
   Accel^[i]:=c;
457
 
   c:=c^.next;
458
 
  end;
459
 
 for i:=1 to pred(Chainlen)do
460
 
  for j:=succ(i)to Chainlen do
461
 
   if length(Accel^[j]^.newvalue^)>=length(Accel^[i]^.oldvalue^)then
462
 
    repeat
463
 
     MustBeReplaced:=false;
464
 
     for kk:=1 to length(Accel^[j]^.newvalue^)do
465
 
      begin
466
 
       sss:=copy(Accel^[j]^.newvalue^,kk,length(Accel^[i]^.oldvalue^));
467
 
       if length(sss)<>length(Accel^[i]^.oldvalue^)then
468
 
        break
469
 
       else if sss=Accel^[i]^.oldvalue^ then
470
 
        begin
471
 
         MustBeReplaced:=(CheckLeft(Accel^[j]^.newvalue^,kk)and CheckRight(Accel^[j]^.newvalue^,kk-1+
472
 
                             length(Accel^[i]^.oldvalue^)));
473
 
         if MustBeReplaced then
474
 
          break;
475
 
        end;
476
 
      end;
477
 
     if MustBeReplaced then
478
 
      begin
479
 
       sss:=Accel^[j]^.newvalue^;
480
 
       delete(sss,kk,length(Accel^[i]^.oldvalue^));
481
 
       insert(Accel^[i]^.newvalue^,sss,kk);
482
 
       freemem(Accel^[j]^.newvalue,length(Accel^[j]^.newvalue^));
483
 
       getmem(Accel^[j]^.newvalue,length(sss));
484
 
       Accel^[j]^.newvalue^:=sss;
485
 
      end;
486
 
    until not MustBeReplaced;
487
 
 for j:=1 to Chainlen do
488
 
  begin
489
 
   sss:=Evaluate(Accel^[j]^.newvalue^);
490
 
   freemem(Accel^[j]^.newvalue,length(Accel^[j]^.newvalue^));
491
 
   getmem(Accel^[j]^.newvalue,length(sss));
492
 
   Accel^[j]^.newvalue^:=sss;
493
 
  end;
494
 
 if isSwitch('C')or isSwitch('-Cheader')then
495
 
  for i:=1 to Chainlen do
496
 
   begin
497
 
    if Accel^[i]^.newvalue^<>''then
498
 
     writeln('#define ',Accel^[i]^.oldvalue^,' ',Accel^[i]^.newvalue^)
499
 
   end
500
 
 else
501
 
  begin
502
 
   sss:='';
503
 
   i:=1;
504
 
   sss:='';
505
 
   while i<=size do
506
 
    begin
507
 
     if buf^[i]<>#10 then
508
 
      sss:=sss+buf^[i]
509
 
     else
510
 
      begin
511
 
       while(sss<>'')and(sss[1]<=#32)do
512
 
        delete(sss,1,1);
513
 
       sst:=sss;
514
 
       for j:=1 to length(sst)do
515
 
        sst[j]:=upcase(sst[j]);
516
 
       if pos('#INCLUDE',sst)=0 then
517
 
        begin
518
 
         s:='';
519
 
         for kk:=1 to length(sss)do
520
 
          begin
521
 
           if sss[kk]>#32 then
522
 
            s:=s+sss[kk]
523
 
           else if s<>'' then
524
 
            begin
525
 
             for j:=1 to ChainLen do
526
 
              begin
527
 
               if accel^[j]^.casesentitive then
528
 
                begin
529
 
                 if(accel^[j]^.oldvalue^=s)and(accel^[j]^.newvalue^<>'')then
530
 
                  begin
531
 
                   s:=accel^[j]^.newvalue^;
532
 
                   break;
533
 
                  end;
534
 
                end
535
 
               else
536
 
                begin
537
 
                 if(accel^[j]^.oldvalue^=Up(s))and(accel^[j]^.newvalue^<>'')then
538
 
                  begin
539
 
                   s:=accel^[j]^.newvalue^;
540
 
                   break;
541
 
                  end;
542
 
                end;
543
 
              end;
544
 
             write(s,' ');
545
 
             s:='';
546
 
            end;
547
 
          end;
548
 
         writeln;
549
 
         sss:='';
550
 
        end
551
 
       else
552
 
        sss:='';
553
 
      end;
554
 
     inc(i);
555
 
    end;
556
 
  end;
557
 
 freemem(Accel,sizeof(pReplaceRec)*ChainLen);
558
 
 Chain:=ChainHdr;
559
 
 while Chain<>nil do
560
 
  begin
561
 
   c:=Chain;
562
 
   Chain:=Chain^.next;
563
 
   if c^.oldvalue<>nil then
564
 
    freemem(c^.oldvalue,succ(length(c^.oldvalue^)));
565
 
   if c^.newvalue<>nil then
566
 
    freemem(c^.newvalue,succ(length(c^.newvalue^)));
567
 
   dispose(c);
568
 
  end;
569
 
 freemem(buf,size);
570
 
end.