dedepfiles.pas

dede 的源代码 3.10b

   GlobWord:='';
   Repeat
     GetNextChar;
     GlobWord:=GlobWord+GlobChar;
     If GlobChar in [''''] then bStringMode:=Not bStringMode;
     If GlobChar in ['[',']'] then bIndexMode:=Not bIndexMode;
   Until (GlobChar in [#0, #10, #13, #32, '(',')', ':', ';', '=','[',']']) and (not bStringMode);
   GlobWord:=Copy(GlobWord,1,Length(GlobWord)-1);
end;

{ TImplementationParser }

procedure TImplementationParser.GetNextChar;
begin
  Inc(GlobPos);
  If GlobPos>FiCharCount
     Then GlobChar:=#0
     Else GlobChar:=FsLowerString[GlobPos];
end;

procedure TImplementationParser.InitParse(sClassString: String;
  OnNewProcedure: TOnNewProcEvent);
begin
  FOnNewProcedure:=OnNewProcedure;

  // DO NOT CALL IT
  // FsString:=RemoveComments(sClassString);
  FsString:=sClassString;
  // FsString:=RemoveIntervals(FsString);

  FsLowerString:=AnsiLowerCase(FsString);
  FiCharCount:=Length(sClassString);
  GlobSize:=Length(FsString);
  GlobPos:=0;
  BegPos:=0;
  GlobChar:=#0;
  GlobWord:='';
  LastWord:='';
  sDeclarationType:='public';
  iLevel:=0;
  bProperty:=False;
  fbReadInherits:=false;
  fbReadIt:=false;
  fsInherits:='';
  FbFound:=False;
  FbInProc:=False;
  FbType:=False;
  FbDontIncreaseParens:=False;
  ErrList.Clear;
end;

procedure TImplementationParser.ParseIt;
begin
  Repeat
    ReadWord;
    ParseWord;
  Until GlobChar=#0;

  if ErrList.Count<>0 then ErrList.SaveToFile(FsTEMPDir+'dcu2dsf_'+IntToStr(GetTickCount)+'.err');
end;

procedure TImplementationParser.ParseWord;
const BytePoses : Array [1..10] of Byte = (12,15,18,21,24,27,30,33,36,39);
var sIdent, sName, sDef   : String;
    iPos, i, j, sz, idx, Offset, iNextOffs, iCurrOffs  : Integer;
    ss : String;
    bt : Byte;
    buffer : TSymBuffer;
    FbFailed : Boolean;

    function Max(x,y : Integer) : Integer;
    begin
      if x>y then result:=x
             else result:=y;
    end;


    procedure FixVal(var ss : String);
    var _s : string;
        i : Integer;
    begin
      _s:='';
      for i:=1 to length(ss) do
        if ss[i] in ['0'..'9','A'..'F'] then _s:=_s+ss[i];

      ss:=_s;
    end;

begin

  if (GlobWord='procedure') or (GlobWord='function')
    then begin
       if FbInProc then Inc(iLevel)
                   else begin
                     //iLevel:=0; {??}
                     POS0:=0;
                     POS1:=GlobPos-Length(GlobWord);
                   end;
       FbInProc:=True;
    end;


  if not FbDontIncreaseParens {POS2=0} then
   // begin is still not found
   // do not parse chars from the code
   begin
     if GlobChar='(' then Inc(iLevel);
     if (iLevel>0) and (GlobChar=')') then Dec(iLevel);
   end;

  if// After the procedure/function is found
    (POS1<>0) and (POS0=0)
    // No parens
    and (iLevel=0)
    //
    and (GlobChar=';')
    then begin
      POS0:=GlobPos;
      FbDontIncreaseParens:=True;
    end;

  if GlobWord='begin'
     then POS2:=GlobPos-5;

  if GlobWord='end' then
     begin
       POS3:=GlobPos-3;
       if iLevel=0 then FbFound:=True;
       if iLevel<>0 then Dec(iLevel);
     end;


  If (FbFound) Then
    try
      sName:=Copy(FsString,POS1,POS0-POS1);
      sDef:=Copy(FsString,POS2+5,POS3-POS2-5);
      TmpStr.Text:=sDef;

      idx:=0; Offset:=0; FbFailed:=False;
      iNextOffs:=0;iCurrOffs:=0;
      //SetLength(buffer,_PatternSize);
      sz:=TmpStr.Count;

      // Skip procs that contains only 1 instruction
      if sz<=2 then
        begin
          FbFound:=False;
          FbFailed:=False;
          POS0:=0;
          POS1:=0;
          POS2:=0;
          exit;
        end;

      For i:=0 to sz-2 Do
        Begin
          sDef:=TmpStr[i];
          if sDef='' then continue;
          if Length(sDef)<3 then continue;
          // 00000000 : 00 00 00 00 00 00 00 00 00 
          // 1234567890123456789012345678901234567890
          // 0        1         2         3         4
          //
          iCurrOffs:=StrToInt('$'+Copy(sDef,1,8));

          // Read the offsets of the current and the next instruction
          // to get instruction length
          if i+1<>sz then ss:='$'+Copy(TmpStr[i+1],1,8);
          Try
           iNextOffs:=StrToInt(ss);
          Except
           On E : EConvertError Do
             Begin
               if i+1<sz then Raise;
             End;
           Else Raise;
          End;


          // Read the bytes
          Try
            // If not last instruction
            if (i+1<>sz) and (iNextOffs<>0) then
              For j:=1 to iNextOffs-iCurrOffs do
               begin
                 ss:=Copy(sDef,
                   // Absolute position of the 0-th byte
                    11
                   // j-th byte position starting from 0 (1,4,7,10,...)
                   //  A1(00 00 00 00 00 00 00 00 00 00
                   //  1234567890123456789012345678901234567890
                   +3*(j-1)+1
                   //Chars to copy
                   ,2);
                 if ss=#32#32 then break;
                 if ss='' then break;
                 bt:=StrToInt('$'+ss);
                 Inc(idx);
                 buffer[idx]:=bt;
                 // PatternSize for DSF version 2.1
                 if idx=_PatternSize then break;
               end

             // If is the last instruction
             else
              For j:=1 to 7 do
               begin
                 ss:=Copy(sDef,BytePoses[j]+Offset,2);
                 if ss=#32#32 then break;
                 if ss='' then break;
                 bt:=StrToInt('$'+ss);
                 Inc(idx);
                 buffer[idx]:=bt;
                 // PatternSize for DSF version 2.1
                 if idx=_PatternSize then break;
               end;
           Except
             FbFailed:=True;
             break;
           End;
         if idx=_PatternSize then break;
        end;

       for i:=idx to _PatternSize-1 do buffer[i]:=0;
       if not FbFailed
          then if Assigned(FOnNewProcedure) then FOnNewProcedure(sName,buffer,_PatternSize, Trunc(100*GlobPos/GlobSize), True)
                                            else
          else ErrList.Add('Cant process: '+sName+' line: "'+sDef+'"');
    Finally
      FbFound:=False;
      FbInProc:=False;
      FbFailed:=False;
      FbDontIncreaseParens:=False;
      POS0:=0;
      POS1:=0;
      POS2:=0;
    End;
end;

procedure TImplementationParser.ReadWord;
begin
   If GlobWord<>''
      Then begin
             LastWord:=GlobWord;
             Delta:=0;
           end ;
   GlobWord:='';
   Repeat
     GetNextChar;
     GlobWord:=GlobWord+GlobChar;
   Until (GlobChar in [#0, #10, #13, #32, '(',')', ':', ';', '=','[',']']);
   GlobWord:=Copy(GlobWord,1,Length(GlobWord)-1);
end;

{ TNewDCU2DSFParser }

procedure TNewDCU2DSFParser.InitParse(aList: TStringList;
  OnNewProcedure: TOnNewProcEvent);
begin
  FOnNewProcedure:=OnNewProcedure;
  List:=aList;
end;

procedure TNewDCU2DSFParser.ParseIt;
const BytePoses : Array [1..10] of Byte = (12,15,18,21,24,27,30,33,36,39);
var i, j, idx : Integer;
    buffer : TSymBuffer;
    sName, s, ss : String;
    bt : Byte;
    bCode : Boolean;
    ProcNameStack : TStringList;

    procedure CheckAndFixRelativeDCUShits(var s : String);
    var k, l : Integer;
    begin
      l:=0;
      for k:=1 to 10 do
       begin
         if Copy(s,BytePoses[k],2)='' then break;
         if Copy(s,BytePoses[k]-1,1)='(' then l:=4;
         if l>0 then
           begin
             s[BytePoses[k]]:='0';
             s[BytePoses[k]+1]:='0';
             Dec(l);
           end;
       end;
    end;
begin
  ProcNameStack:=TStringList.Create;
  Try
    For i:=0 to List.Count-1 Do
     Begin
        s:=Trim(List[i]);

        if   (Copy(s,1,8)='function')
          or (Copy(s,1,9)='procedure')
          then begin
            ProcNameStack.Add(s);
            Continue;
          end;

        if s='begin' then
          begin
            bCode:=True;
            idx:=0;
            Continue;
          end;

        if s='end;' then
          begin
             for j:=idx+1 to _PatternSize-1 do buffer[j]:=0;
             j:=ProcNameStack.Count;
             if j=0 then exit;
             sName:=ProcNameStack[j-1];
             // Add only patterns with more than 6 bytes
             if Assigned(FOnNewProcedure) then FOnNewProcedure(sName,buffer,_PatternSize, Trunc(100*i/List.Count),idx>=6);
             ProcNameStack.Delete(j-1);
             bCode:=False;
             Continue;
          end;


        if bCode then
         begin
          CheckAndFixRelativeDCUShits(s);
          For j:=1 to 10 do
           begin
             ss:=Copy(s,BytePoses[j],2);
             if (ss='') or (ss=' ') then break;
             Try
               bt:=StrToInt('$'+ss);
             Except
               GlobPreParseWarning:=$DEDE;
               Exit;
             End;
             Inc(idx);
             buffer[idx]:=bt;
             // PatternSize for DSF version 2.1
             if idx=_PatternSize then
               begin
                 bCode:=False;
                 break;
               end;
           end;
         end;  
     End;
  Finally
    ProcNameStack.Free;
  End;
end;

initialization
  TmpStr:=TStringList.Create;
  ErrList:=TStringList.Create;

finalization
  TmpStr.Free;
  ErrList.Free;

end.