dedepproject.pas

dede 的源代码 3.10b

              Rs:=Copy(s,rPos+6,wPos-rPos-6);
              if sPos=0
                 then Ws:=Copy(s,wPos+7,sPos-wPos-7)
                 else
                 if dPos=0 then Ws:=Copy(s,wPos+7,Length(s)-wPos-7)
                           else Ws:=Copy(s,wPos+7,dPos-wPos-7);
           end
           else begin
              if sPos<>0
                 then Rs:=Copy(s,rPos+7,sPos-rPos-7)
                 else
                 if dPos=0 then Rs:=Copy(s,rPos+6,Length(s)-rPos-6)
                           else Rs:=Copy(s,rPos+6,dPos-rPos-6);
              Ws:='';
           end
         else if wPos<>0
          then begin
              Rs:='';
              if sPos=0
                 then Ws:=Copy(s,wPos+7,sPos-wPos-7)
                 else
                 if dPos=0 then Ws:=Copy(s,wPos+7,Length(s)-wPos-7)
                           else Ws:=Copy(s,wPos+7,dPos-wPos-7);
          end
          else begin
              Rs:='';
              Ws:='';
          end;

      if rPos<>0
        then
          if iPos=0 then s:=Copy(s,1,rPos-1)
                    else s:=Copy(s,1,iPos-1)
        else if wPos<>0
          then
            if iPos=0 then s:=Copy(s,1,wPos-1)
                      else s:=Copy(s,1,iPos-1)
          else
            if iPos=0 then if dPos<>0 then s:=Copy(s,1,dPos-1)
                                      else if sPos<>0 then s:=Copy(s,1,sPos-1)
                      else s:=Copy(s,1,iPos-1);


    end;

    var lp,rp,i : Integer;
        sit,stmp   : String;
begin
   sProto:=s;

   While Pos(PREFIX_TYPEDECLR,sProto)<>0 Do
     Begin
       iPos:=Pos(PREFIX_TYPEDECLR,sProto);
       Delete(sProto,iPos,Length(PREFIX_TYPEDECLR));
     End;

   // 'inst' ....
   sProto:=Copy(sProto,6,Length(s)-5);
   // .... ';'
   While Copy(sProto,Length(sProto),1)=';' do  sProto:=Copy(sProto,1,Length(sProto)-1);
   if not bProp
     then begin
       // Method
       if s1<>'' then sProto:=sProto+' '+Copy(s1,1,Length(s1)-1);
       sProto:=Trim(sProto);
       sClassDecl:=sClassDecl+'s:='''+sProto+''';'#13#10+s+#13#10;
     end
     else begin
       // Property - may have read RBlah write RBlah
        ParseReadWrite(s1,s_r,s_w);
        s1:=Trim(s1); If (Length(s1)>0) and (s1[1]=':') then s1:=Copy(s1,2,Length(s1)-1);s1:=Trim(s1);
        st:=GetTypeVarName(s1);
        if (s1<>'') then  sProto:=sProto+' |'+s1;//Copy(s1,2,Length(s1)-1);

        // Blah[Index : Integer] : TBlah
        if Pos('[',s)<>0 then
          begin
            lp:=Pos('[',s);
            rp:=Pos(']',s);
            sit:=copy(s,lp+1,rp-lp-1);
            sit:=Trim(sit);
            stmp:='';
            for i:=Length(sit) downto 1 do
              if sit[i]<>':' then stmp:=sit[i]+stmp
                             else break;
            stmp:=Trim(stmp);
            stmp:=GetTypeVarName(stmp);
            s1:='';
            repeat
              i:=Pos(',',sit);
              sit:=Copy(sit,i+1,Length(sit)-i);
              s1:=s1+stmp+',';
            until i=0;
            s1:=Copy(s1,1,Length(s1)-1);
            s:=Copy(s,1,lp-1)+'['+s1+']'+Copy(s,rp+1,Length(s)-rp);
          end;

        sProto:=Trim(sProto);
        if s_r<>'' then sClassDecl:=sClassDecl+'s:='''+sProto+'<r_'+s_r+'>'+''';'#13#10+st+':='+s+';'#13#10;
        if s_w<>'' then sClassDecl:=sClassDecl+'s:='''+sProto+'<w_'+s_w+'>'+''';'#13#10+s+':='+st+';'#13#10;
     end;


end;

procedure AddMethod(sDeclaration : String);
var i,iPos : Integer;
    sCode, sParam : String;

    procedure ParseParams(s:String);
    var j, k : Integer;
        tmp : TStringList;
        s1, st : String;
    begin
      tmp:=TStringList.Create;
      try
        // Default values
        j:=Pos('=',s);
        if j<>0 then s:=Copy(s,1,j-1)+';';

        j:=Pos(':',s);
        if j=0 then
           begin
             //(untyped)
             s1:='Pointer';
           end
           else begin
              s1:=Copy(s,j+1,Length(s)-j);
              s:=Copy(s,1,j-1);
           end;
        tmp.CommaText:=s;
        st:=Trim(s1);
        st:=GetTypeVarName(st);
        For j:=0 to tmp.Count-1 Do
          if     (LowerCase(tmp[j])<>'const')
             and (LowerCase(tmp[j])<>'var')
             and (LowerCase(tmp[j])<>'out') then sCode:=sCode+st+',';
      finally
        tmp.free;
      end;
    end;

var bFlag : Boolean;
    sResType : String;

begin
  iPos:=Pos('(',sDeclaration);
  // No parameters
  if iPos=0 then
   begin
    if Pos(':',sDeclaration)<>0 then
     begin
       bFlag:=False;sCode:='';   sResType:='';
       For iPos:=Length(sDeclaration) downto 1 Do
         begin
          if bFlag then sCode:=sDeclaration[iPos]+sCode
                   else sResType:=sDeclaration[iPos]+sResType;
          if sDeclaration[iPos] in [':'] then bFlag:=True;
         end;
      end
      else begin
        sCode:=sDeclaration;
        sResType:='';
      end;
     AddCode('inst.'+sCode+';',sResType);
     Exit;
   end;

  sCode:=Copy(sDeclaration,1,iPos);
  sParam:=Copy(sDeclaration,iPos+1,Length(sDeclaration));

  iPos:=Pos(')',sParam);
  sResType:=Copy(sParam,iPos+1,Length(sParam)-iPos);
  sParam:=Copy(sParam,1,iPos-1);
  // Parsing Parameters
  Repeat
    iPos:=Pos(';',sParam);
    ParseParams(Copy(sParam,1,iPos-1));
    sParam:=Copy(sParam,iPos+1,Length(sParam)-iPos);
  Until iPos=0;
  ParseParams(sParam);
  // Clean last comma !
  sCode:=Copy(sCode,1,Length(sCode)-1);
  sCode:=sCode+');';
  AddCode('inst.'+sCode,sResType);
end;

procedure AddProperty(sDeclaration : String);
var bFlag : Boolean;
    sResType, sCode : String;
    iPos : Integer;
begin
  // Items[Index : Integer] : TBlahItem
  if Pos('[',sDeclaration)<>0 then
   begin
   end;

  if Pos(':',sDeclaration)<>0 then
   begin
     bFlag:=False;sCode:='';sResType:='';
     For iPos:=Length(sDeclaration) downto 1 Do
       begin
        if bFlag then sCode:=sDeclaration[iPos]+sCode
                 else sResType:=sDeclaration[iPos]+sResType;
        if sDeclaration[iPos] in [':'] then bFlag:=True;

       end;

       AddCode('inst.'+sCode,sResType,True);
    end;
end;

procedure PrepareToSave(sINIT_DIR : String);
var sr : TSearchRec;
    b : Boolean;      
begin              
  INIT_DIR:=sINIT_DIR+'\OutPut_DOI_';
  b:=FindFirst(INIT_DIR,faDirectory,sr)=0;
 // sINIT_DIR:=sr.Name;
  FindClose(sr);
  if not b then
    begin
      ChDir(sINIT_DIR);
      MkDir('OutPut_DOI_');
    end;
end;

Procedure InitializeFixups;
Begin
  //GlobTypeFIXList.Add('tbitmap');GlobTypeFIXEDList.Add('tagBITMAP');
end;

Procedure InitializeSkips;
Begin
  GlobTypeSKIPList.Add('TResourceManager');

  GlobClassSKIPList.Add('TConnectionPoint');
end;


initialization
  VarTypesList:=TStringList.Create;
  CodeList:=TStringList.Create;
  PublishedMethList:=TStringList.Create;
  PublishedFieldList:=TStringList.Create;
  ImplementationList:=TStringList.Create;
  DFMStream:=TMemoryStream.Create;
  GlobTypeFIXList:=TStringList.Create;
  GlobTypeFIXEDList:=TStringList.Create;
  InitializeFixups;
  GlobTypeSKIPList:=TStringList.Create;
  GlobClassSKIPList:=TStringList.Create;
  InitializeSkips;

finalization
  VarTypesList.Free;
  PublishedMethList.Free;
  PublishedFieldList.Free;
  ImplementationList.Free;
  CodeList.Free;
  DFMStream.Free;
  GlobTypeFIXList.Free;
  GlobTypeFIXEDList.Free;
  GlobTypeSKIPList.free;
  GlobClassSKIPList.Free;

end.