← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to utils/fprcp/fprcp.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

Lines of Context:
utils/fprcp/fprcp.pp
4
4
{$endif}
5
5
{$ifndef fpc}{$N+}{$endif}
6
6
uses
7
 
 Comments,PasPrep,Expr
 
7
 Comments,PasPrep,Expr,Classes
8
8
{$ifndef win32}
9
9
,DOS;
10
10
type
57
57
var
58
58
 f:file;
59
59
 s:str255;
 
60
 sValue1, sValue2: String;
60
61
 size,nextpos:longint;
61
62
 buf:pchars;
62
63
 i:longint;
 
64
 AConstList: TStringList;
 
65
 
63
66
function Entry(buf:pchars;Size,fromPos:longint;const sample:str255;casesent:longbool):longbool;
64
67
 var
65
68
  i:longint;
171
174
   if paramstr(i)='-'+switch then
172
175
    GetSwitch:=paramstr(succ(i));
173
176
 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;
 
177
 
198
178
type
199
179
 Tlanguage=(L_C,L_Pascal);
200
180
function Language(s:str255):tLanguage;
270
250
   n[i]:=upcase(s[i]);
271
251
  Up:=n;
272
252
 end;
 
253
procedure saveproc(const key,value:str255;CaseSent:longbool);{$ifndef fpc}far;{$endif}
 
254
begin
 
255
  AConstList.Values[Up(key)]:=Up(Value);
 
256
end;
 
257
 
273
258
procedure do_C(buf:pchars;size:longint;proc:pointer);
274
259
 type
275
260
  Tpushfunc=procedure(const key,value:str255;CaseSent:longBool);
339
324
 end;
340
325
function do_include(name:str255):longbool;
341
326
 var
342
 
  buf:pchars;
343
 
  f:file;
344
 
  size:longint;
 
327
  bufinclude:pchars;
 
328
  finclude:file;
 
329
  sizeinclude:longint;
345
330
  s1:str255;
346
331
 procedure trim;
347
332
  begin
359
344
     s1:=GetSwitch('-path');
360
345
    expandname(name,s1);
361
346
   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);
 
347
  assign(finclude,name);
 
348
  reset(finclude,1);
 
349
  sizeinclude:=filesize(finclude);
 
350
  GetMem(bufinclude,sizeinclude);
 
351
  blockread(finclude,bufinclude^,sizeinclude);
 
352
  close(finclude);
368
353
  case Language(name)of
369
354
   L_C:
370
 
    do_C(buf,size,@saveProc);
 
355
    do_C(bufinclude,sizeinclude,@saveProc);
371
356
   L_PASCAL:
372
 
    do_pascal(buf,size,@saveProc);
 
357
    do_pascal(bufinclude,sizeinclude,@saveProc);
373
358
  end;
374
 
  FreeMem(buf,size);
 
359
  FreeMem(bufinclude,sizeinclude);
375
360
  do_include:=true;
376
361
 end;
377
362
function CheckRight(const s:str255;pos:longint):longbool;
393
378
     CheckLeft:=not(s[pred(pos)]in['a'..'z','A'..'Z','0'..'9','_']);
394
379
   end;
395
380
 end;
396
 
function Evaluate(Equation:Str255):Str255;
 
381
function Evaluate(Equation:String):String;
397
382
 var
398
383
  x:double;
399
384
  Err:integer;
400
385
 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;
 
386
   Eval(Equation,x,Err);
 
387
   if(Err=0)and(frac(x)=0)then
 
388
    str(x:1:0,Equation)
 
389
   else
 
390
    Equation:='';
 
391
   Evaluate:=Equation;
 
392
end;
 
393
 
408
394
type
409
395
 taccel=array[1..100]of pReplaceRec;
410
396
var
412
398
 c:pReplaceRec;
413
399
 j,kk:longint;
414
400
 sss,sst:str255;
415
 
 MustBeReplaced:longbool;
 
401
 bNoMore:Boolean;
416
402
begin
417
403
 if(paramcount=0)or isSwitch('h')or isSwitch('-help')or((paramcount>1)and(GetSwitch('i')=''))then
418
404
  begin
441
427
 if isSwitch('-disable-nested-pascal-comments')then
442
428
  PasNesting:=false;
443
429
 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
 
430
 
 
431
 AConstList:=TStringList.Create;
 
432
 //try
 
433
  AConstList.BeginUpdate;
 
434
  //try
 
435
   //include file
 
436
   for i:=1 to size do
 
437
    begin
 
438
     if entry(buf,size,i,'#include',true)then
 
439
      do_include(GetWord(buf,size,i+length('#include'),nextpos));
 
440
    end;
 
441
   //finally 
 
442
   AConstList.EndUpdate; //end;
 
443
 
 
444
   //replace const-value if needed and evaluate
 
445
   For i:=0 to (AConstList.Count-1) do begin
 
446
    sValue1:=AConstList.ValueFromIndex[i];
462
447
    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
 
448
     sValue2:=AConstList.Values[sValue1];
 
449
     bNoMore:=Length(sValue2)=0;
 
450
     if (not bNoMore) then sValue1:=sValue2;
 
451
    until bNoMore;
 
452
    sValue2:=Evaluate(sValue1);
 
453
    if Length(sValue2)>0
 
454
    then AConstList.ValueFromIndex[i]:=Evaluate(sValue1);
 
455
   end;
 
456
 
 
457
   if isSwitch('C')or isSwitch('-Cheader')then begin
 
458
    for i:=0 to AConstList.Count-1
 
459
    do writeln('#define ',AConstList.Names[i],' ',AConstList.ValueFromIndex[i]);
 
460
   end else begin
 
461
    sss:='';
 
462
    i:=1;
 
463
    while i<=size do
 
464
     begin
 
465
      if buf^[i]<>#10 then
 
466
       sss:=sss+buf^[i]
 
467
      else
 
468
       begin
 
469
        while(sss<>'')and(sss[1]<=#32)do
 
470
         delete(sss,1,1);
 
471
        sst:=sss;
 
472
        for j:=1 to length(sst)do sst[j]:=upcase(sst[j]);
 
473
        if pos('#INCLUDE',sst)=0 then
520
474
          begin
521
 
           if sss[kk]>#32 then
522
 
            s:=s+sss[kk]
523
 
           else if s<>'' then
 
475
           s:='';
 
476
           for kk:=1 to length(sss)do
524
477
            begin
525
 
             for j:=1 to ChainLen do
 
478
             if sss[kk]>#32 then
 
479
              s:=s+sss[kk]
 
480
             else if s<>'' then
526
481
              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;
 
482
               sValue1:=AConstList.Values[Up(s)];
 
483
               if Length(sValue1)>0
 
484
               then write(sValue1,' ')
 
485
               else write(s,' ');
 
486
               s:='';
543
487
              end;
544
 
             write(s,' ');
545
 
             s:='';
546
488
            end;
547
 
          end;
548
 
         writeln;
549
 
         sss:='';
550
 
        end
551
 
       else
552
 
        sss:='';
553
 
      end;
554
 
     inc(i);
 
489
           writeln;
 
490
           sss:='';
 
491
          end
 
492
         else
 
493
          sss:='';
 
494
       end;
 
495
       inc(i);
 
496
     end;
555
497
    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);
 
498
   freemem(buf,size);
 
499
 
 
500
 //finally 
 
501
 AConstList.Free; //end;
 
502
 
570
503
end.