home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d456 / CAJSCRPT.ZIP / ifps3 / demo_kylix / ifps3disasm.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-07-12  |  12.1 KB  |  408 lines
  1. unit ifps3disasm;
  2. {$I ifps3_def.inc}
  3.  
  4. interface
  5. uses
  6.   ifps3, ifps3utl, ifps3common, sysutils;
  7.  
  8. function IFPS3DataToText(const Input: string; var Output: string): Boolean;
  9. implementation
  10.  
  11. type
  12.   TMyIFPSExec = class(TIFPSExec)
  13.     function ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean; override;
  14.   end;
  15.  
  16. function Debug2Str(const s: string): string;
  17. var
  18.   i: Integer;
  19. begin
  20.   result := '';
  21.   for i := 1 to length(s) do
  22.   begin
  23.     if (s[i] < #32) or (s[i] > #128) then
  24.       result := result + '\'+inttohex(ord(s[i]), 2)
  25.     else if s[i] = '\' then
  26.       result := result + '\\'
  27.     else
  28.       result := result + s[i]; 
  29.   end;
  30.  
  31. end;
  32.  
  33. function SpecImportProc(Sender: TObject; p: PIFProcRec): Boolean; forward;
  34.  
  35.  
  36. function IFPS3DataToText(const Input: string; var Output: string): Boolean;
  37. var
  38.   I: TMyIFPSExec;
  39.  
  40.   procedure Writeln(const s: string);
  41.   begin
  42.     Output := Output + s + #13#10;
  43.   end;
  44.   function BT2S(const S: TIFPSBaseType): string;
  45.   begin
  46.     case s of
  47.       btU8: Result := 'U8';
  48.       btS8: Result := 'S8';
  49.       btU16: Result := 'U16';
  50.       btS16: Result := 'S16';
  51.       btU32: Result := 'U32';
  52.       btS32: Result := 'S32';
  53.       btSingle: Result := 'Single';
  54.       btDouble: Result := 'Double';
  55.       btExtended: Result := 'Extended';
  56.       btString: Result := 'String';
  57.       btRecord: Result := 'Record';
  58.       btArray: Result := 'Array';
  59.       btResourcePointer: Result := 'ResourcePointer';
  60.       btPointer: Result := 'Pointer';
  61.       btVariant: Result := 'Variant';
  62.     else
  63.       Result := 'Unknown';
  64.     end;
  65.   end;
  66.   procedure WriteTypes;
  67.   var
  68.     T: Longint;
  69.   begin
  70.     Writeln('[TYPES]');
  71.     for T := 0 to i.FTypes.Count -1 do
  72.     begin
  73.       if PIFTypeRec(i.FTypes.getItem(t))^.ExportName <> '' then
  74.         Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes.getItem(t))^.BaseType)+' Export: '+PIFTypeRec(i.FTypes.getItem(t))^.ExportName)
  75.       else
  76.         Writeln('Type ['+inttostr(t)+']: '+bt2s(PIFTypeRec(i.FTypes.getItem(t))^.BaseType));
  77.     end;
  78.   end;
  79.   procedure WriteVars;
  80.   var
  81.     T: Longint;
  82.     function FindType(p: Pointer): Cardinal;
  83.     var
  84.       T: Longint;
  85.     begin
  86.       Result := Cardinal(-1);
  87.       for T := 0 to i.FTypes.Count -1 do
  88.       begin
  89.         if p = i.FTypes.GetItem(t) then begin
  90.           result := t;
  91.           exit;
  92.         end;
  93.       end;
  94.     end;
  95.   begin
  96.     Writeln('[VARS]');
  97.     for t := 0 to i.FGlobalVars.count -1 do
  98.     begin
  99.       Writeln('Var ['+inttostr(t)+']: '+ IntToStr(FindType(PIFVariant(i.FGlobalVars.GetItem(t))^.FType)) + ' '+ bt2s(PIFVariant(i.FGlobalVars.GetItem(t))^.Ftype^.BaseType) + ' '+ PIFVariant(i.FGlobalVars.GetItem(t))^.Ftype^.ExportName);
  100.     end;
  101.   end;
  102.  
  103.   procedure WriteProcs;
  104.   var
  105.     t: Longint;
  106.     procedure WriteProc(proc: PIFProcRec);
  107.     var
  108.       CP: Cardinal;
  109.       function ReadData(var Data; Len: Cardinal): Boolean;
  110.       begin
  111.         if CP + Len <= PROC .Length then begin
  112.           Move(Proc.Data^[CP], Data, Len);
  113.           CP := CP + Len;
  114.           Result := True;
  115.         end else Result := False;
  116.       end;
  117.       function ReadByte(var B: Byte): Boolean;
  118.       begin
  119.         if CP < Proc.Length then begin
  120.           b := Proc.Data^[cp];
  121.           Inc(CP);
  122.           Result := True;
  123.         end else Result := False;
  124.       end;
  125.  
  126.       function ReadLong(var B: Cardinal): Boolean;
  127.       begin
  128.         if CP + 3 < Proc.Length then begin
  129.           b := Cardinal((@Proc.Data^[CP])^);
  130.           Inc(CP, 4);
  131.           Result := True;
  132.         end else Result := False;
  133.       end;
  134.       function ReadWriteVariable: string;
  135.       var
  136.         VarType: byte;
  137.         L1, L2: Cardinal;
  138.         function ReadVar(FType: Cardinal): string;
  139.         var
  140.           F: PIFTypeRec;
  141.           b: byte;
  142.           w: word;
  143.           l: Cardinal;
  144.           e: extended;
  145.           ss: single;
  146.           d: double;
  147.           s: string;
  148.           function strtostr(const S: string): string;
  149.           var
  150.            i : Longint;
  151.           begin
  152.             result := '''';
  153.             for i := 1 to length(s) do
  154.             begin
  155.               if s[i] = '''' then result := result + '''''' else
  156.               if s[i] in [#32..#127] then result := result + s[i] else
  157.               result := result + '''#'+inttostr(ord(s[i]))+'''';
  158.             end;
  159.             result := result + '''';
  160.           end;
  161.  
  162.         begin
  163.           result := '';
  164.           F:= i.FTypes.GetItem(Ftype);
  165.           if f = nil then exit;
  166.           case f^.BaseType of
  167.             btU8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbtu8(B)); end;
  168.             btS8: begin if not ReadData(b, 1) then exit; Result := IntToStr(tbts8(B)); end;
  169.             btU16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbtu16(w)); end;
  170.             btS16: begin if not ReadData(w, 2) then exit; Result := IntToStr(tbts16(w)); end;
  171.             btU32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbtu32(l)); end;
  172.             btS32: begin if not ReadData(l, 4) then exit; Result := IntToStr(tbts32(l)); end;
  173.             btSingle: begin if not ReadData(ss, Sizeof(tbtsingle)) then exit; Result := FloatToStr(ss); end;
  174.             btDouble: begin if not ReadData(d, Sizeof(tbtdouble)) then exit; Result := FloatToStr(d); end;
  175.             btExtended: begin if not ReadData(e, Sizeof(tbtextended)) then exit; Result := FloatToStr(e); end;
  176.             btPChar, btString: begin if not ReadData(l, 4) then exit; SetLength(s, l); if not readData(s[1], l) then exit; Result := strtostr(s); end;
  177.           end;
  178.         end;
  179.         function AddressToStr(a: Cardinal): string;
  180.         begin
  181.           if a < IFPSAddrNegativeStackStart then
  182.             Result := 'GlobalVar['+inttostr(a)+']'
  183.           else
  184.             Result := 'Base['+inttostr(Longint(A-IFPSAddrStackStart))+']';
  185.         end;
  186.  
  187.       begin
  188.         Result := '';
  189.         if not ReadByte(VarType) then Exit;
  190.         case VarType of
  191.           0:
  192.           begin
  193.  
  194.             if not ReadLong(L1) then Exit;
  195.             Result := AddressToStr(L1);
  196.           end;
  197.           1:
  198.           begin
  199.             if not ReadLong(L1) then Exit;
  200.             Result := '['+ReadVar(l1)+']';
  201.           end;
  202.           2:
  203.           begin
  204.             if not ReadLong(L1) then Exit;
  205.             if not ReadLong(L2) then Exit;
  206.             Result := AddressToStr(L1)+'.['+inttostr(l2)+']';
  207.           end;
  208.           3:
  209.           begin
  210.             if not ReadLong(l1) then Exit;
  211.             if not ReadLong(l2) then Exit;
  212.             Result := AddressToStr(L1)+'.'+AddressToStr(l2);
  213.           end;
  214.         end;
  215.       end;
  216.  
  217.     var
  218.       b: Byte;
  219.       s: string;
  220.       DP, D1, D2: Cardinal;
  221.  
  222.     begin
  223.       CP := 0;
  224.       while true do
  225.       begin
  226.         DP := cp;
  227.         if not ReadByte(b) then Exit;
  228.         case b of
  229.           CM_A:
  230.           begin
  231.  
  232.             Writeln(' ['+inttostr(dp)+'] ASSIGN '+ReadWriteVariable+ ', ' + ReadWriteVariable);
  233.           end;
  234.           CM_CA:
  235.           begin
  236.             if not ReadByte(b) then exit;
  237.             case b of
  238.             0: s:= '+';
  239.             1: s := '-';
  240.             2: s := '*';
  241.             3: s:= '/';
  242.             4: s:= 'MOD';
  243.             5: s:= 'SHL';
  244.             6: s:= 'SHR';
  245.             7: s:= 'AND';
  246.             8: s:= 'OR';
  247.             9: s:= 'XOR';
  248.             else
  249.               exit;
  250.             end;
  251.             Writeln(' ['+inttostr(dp)+'] CALC '+ReadWriteVariable+ ' '+s+' ' + ReadWriteVariable);
  252.           end;
  253.           CM_P:
  254.           begin
  255.             Writeln(' ['+inttostr(dp)+'] PUSH '+ReadWriteVariable);
  256.           end;
  257.           CM_PV:
  258.           begin
  259.             Writeln(' ['+inttostr(dp)+'] PUSHVAR '+ReadWriteVariable);
  260.           end;
  261.           CM_PO:
  262.           begin
  263.             Writeln(' ['+inttostr(dp)+'] POP');
  264.           end;
  265.           Cm_C:
  266.           begin
  267.             if not ReadLong(D1) then exit;
  268.             Writeln(' ['+inttostr(dp)+'] CALL '+inttostr(d1));
  269.           end;
  270.           Cm_G:
  271.           begin
  272.             if not ReadLong(D1) then exit;
  273.             Writeln(' ['+inttostr(dp)+'] GOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
  274.           end;
  275.           Cm_CG:
  276.           begin
  277.             if not ReadLong(D1) then exit;
  278.             Writeln(' ['+inttostr(dp)+'] COND_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
  279.           end;
  280.           Cm_CNG:
  281.           begin
  282.             if not ReadLong(D1) then exit;
  283.             Writeln(' ['+inttostr(dp)+'] COND_NOT_GOTO currpos + '+IntToStr(d1)+' '+ReadWriteVariable+' ['+IntToStr(CP+d1)+']');
  284.           end;
  285.           Cm_R: Writeln(' ['+inttostr(dp)+'] RET');
  286.           Cm_ST:
  287.           begin
  288.             if not ReadLong(d1) or not readLong(d2) then exit;
  289.             Writeln(' ['+inttostr(dp)+'] SETSTACKTYPE Base['+inttostr(d1)+'] '+inttostr(d2));
  290.           end;
  291.           Cm_Pt:
  292.           begin
  293.             if not ReadLong(D1) then exit;
  294.             Writeln(' ['+inttostr(dp)+'] PUSHTYPE '+inttostr(d1));
  295.           end;
  296.           CM_CO:
  297.           begin
  298.             if not readByte(b) then exit;
  299.             case b of
  300.               0: s := '>=';
  301.               1: s := '<=';
  302.               2: s := '>';
  303.               3: s := '<';
  304.               4: s := '<>';
  305.               5: s := '=';
  306.               else exit;
  307.             end;
  308.             Writeln(' ['+inttostr(dp)+'] COMPARE into '+ReadWriteVariable+': '+ReadWriteVariable+' '+s+' '+ReadWriteVariable);
  309.           end;
  310.           Cm_cv:
  311.           begin
  312.             Writeln(' ['+inttostr(dp)+'] CALLVAR '+ReadWriteVariable);
  313.           end;
  314.           cm_sp:
  315.           begin
  316.             Writeln(' ['+inttostr(dp)+'] SETPOINTER '+ReadWriteVariable+': '+ReadWriteVariable);
  317.           end;
  318.           cm_bn:
  319.           begin
  320.             Writeln(' ['+inttostr(dp)+'] NOT '+ReadWriteVariable);
  321.           end;
  322.           cm_vm:
  323.           begin
  324.             Writeln(' ['+inttostr(dp)+'] MINUS '+ReadWriteVariable);
  325.           end;
  326.           cm_sf:
  327.            begin
  328.              s := ReadWriteVariable;
  329.              if not ReadByte(b) then exit;
  330.              if b = 0 then
  331.                Writeln(' ['+inttostr(dp)+'] SETFLAG '+s)
  332.              else
  333.                Writeln(' ['+inttostr(dp)+'] SETFLAG NOT '+s);
  334.            end;
  335.            cm_fg:
  336.            begin
  337.              if not ReadLong(D1) then exit;
  338.              Writeln(' ['+inttostr(dp)+'] FLAGGOTO currpos + '+IntToStr(d1)+' ['+IntToStr(CP+d1)+']');
  339.            end;
  340.         else
  341.           begin
  342.             Writeln(' Disasm Error');
  343.             Break;
  344.           end;
  345.         end;
  346.       end;
  347.     end;
  348.  
  349.   begin
  350.     Writeln('[PROCS]');
  351.     for t := 0 to i.FProcs.Count -1 do
  352.     begin
  353.       if PIFProcRec(i.FProcs.GetItem(t))^.ExternalProc then
  354.       begin
  355.         if PIFProcRec(i.FProcs.GetItem(t))^.ExportDecl = '' then
  356.           Writeln('Proc ['+inttostr(t)+']: External: '+PIFProcRec(i.FProcs.GetItem(t))^.Name)
  357.         else
  358.           Writeln('Proc ['+inttostr(t)+']: External Decl: '+Debug2Str(PIFProcRec(i.FProcs.GetItem(t))^.ExportDecl));
  359.       end else begin
  360.         if PIFProcRec(i.FProcs.GetItem(t))^.ExportName <> '' then
  361.         begin
  362.           Writeln('Proc ['+inttostr(t)+'] Export: '+PIFProcRec(i.FProcs.GetItem(t))^.ExportName+' '+PIFProcRec(i.FProcs.GetItem(t))^.ExportDecl);
  363.         end else
  364.           Writeln('Proc ['+inttostr(t)+']');
  365.         Writeproc(i.FProcs.GetItem(t));
  366.       end;
  367.     end;
  368.   end;
  369.  
  370. begin
  371.   Result := False;
  372.   I := TMyIFPSExec.Create;
  373.   I.AddSpecialProcImport('', @SpecImportProc, nil);
  374.  
  375.   if not I.LoadData(Input) then begin
  376.     I.Free;
  377.     Exit;
  378.   end;
  379.   Output := '';
  380.   WriteTypes;
  381.   WriteVars;
  382.   WriteProcs;
  383.   I.Free;
  384. end;
  385.  
  386. { TMyIFPSExec }
  387.  
  388. function MyDummyProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
  389. begin
  390.   Result := False;
  391. end;
  392.  
  393.  
  394. function TMyIFPSExec.ImportProc(const Name: ShortString;
  395.   var proc: TIFProcRec): Boolean;
  396. begin
  397.   Proc.ProcPtr := MyDummyProc;
  398.   result := true;
  399. end;
  400.  
  401. function SpecImportProc(Sender: TObject; p: PIFProcRec): Boolean;
  402. begin
  403.   p.ProcPtr := MyDummyProc;
  404.   Result := True;
  405. end;
  406.  
  407. end.
  408.