jclcil.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclCIL.pas.                                                                 }
{                                                                                                  }
{ The Initial Developer of the Original Code is Flier Lu (<flier_lu att yahoo dott com dott cn>).  }
{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved.                    }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Flier Lu (flier)                                                                               }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Olivier Sannier (obones)                                                                       }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Microsoft .Net CIL Instruction Set information support routines and classes.                     }
{                                                                                                  }
{ Unit owner: Flier Lu                                                                             }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file

unit JclCIL;

interface

{$I jcl.inc}

uses
  {$IFDEF MSWINDOWS}
  Windows, 
  {$ENDIF MSWINDOWS}
  Classes, SysUtils,
  {$IFDEF RTL130_UP}
  Contnrs,
  {$ENDIF RTL130_UP}
  JclBase, JclSysUtils, JclClr, JclMetadata;

type
  TJclOpCode =
   (opNop, opBreak,
    opLdArg_0, opLdArg_1, opLdArg_2, opLdArg_3,
    opLdLoc_0, opLdLoc_1, opLdLoc_2, opLdLoc_3,
    opStLoc_0, opStLoc_1, opStLoc_2, opStLoc_3,
    opldArg_s, opLdArga_s, opStArg_s,
    opLdLoc_s, opLdLoca_s, opStLoc_s,
    opLdNull, opLdc_I4_M1,
    opLdc_I4_0, opLdc_I4_1, opLdc_I4_2, opLdc_I4_3, opLdc_I4_4,
    opLdc_I4_5, opLdc_I4_6, opLdc_I4_7, opLdc_I4_8, opLdc_I4_s,
    opLdc_i4, opLdc_i8, opLdc_r4, opLdc_r8,
    opUnused49,
    opDup, opPop, opJmp, opCall, opCalli, opRet,
    opBr_s, opBrFalse_s, opBrTrue_s,
    opBeq_s, opBge_s, opBgt_s, opBle_s, opBlt_s,
    opBne_un_s, opBge_un_s, opBgt_un_s, opBle_un_s, opBlt_un_s,
    opBr, opBrFalse, opBrTrue,
    opBeq, opBge, opBgt, opBle, opBlt,
    opBne_un, opBge_un, opBgt_un, opBle_un, opBlt_un,
    opSwitch,
    opLdInd_i1, opLdInd_i2, opLdInd_u1, opLdInd_u2,
    opLdInd_i4, opLdInd_u4, opLdInd_i8, opLdInd_i,
    opLdInd_r4, opLdInd_r8, opLdInd_ref, opStInd_ref,
    opStInd_i1, opStInd_i2, opStInd_i4, opStInd_i8,
    opStInd_r4, opStInd_r8,
    opAdd, opSub, opMul, opDiv, opDiv_un, opRem, opRem_un,
    opAnd, opOr, opXor, opShl, opShr, opShr_un, opNeg, opNot,
    opConv_i1, opConv_i2, opConv_i4, opConv_i8,
    opConv_r4, opConv_r8, opConv_u4, opConv_u8,
    opCallVirt, opCpObj, opLdObj, opLdStr, opNewObj,
    opCastClass, opIsInst, opConv_r_un,
    opUnused58, opUnused1,
    opUnbox, opThrow,
    opLdFld, opLdFlda, opStFld, opLdsFld, opLdsFlda, opStsFld, opStObj,
    opConv_ovf_i1_un, opConv_ovf_i2_un, opConv_ovf_i4_un, opConv_ovf_i8_un,
    opConv_ovf_u1_un, opConv_ovf_u2_un, opConv_ovf_u4_un, opConv_ovf_u8_un,
    opConv_ovf_i_un, opConv_ovf_u_un,
    opBox, opNewArr, opLdLen,
    opLdElema, opLdElem_i1, opLdElem_u1, opLdElem_i2, opLdElem_u2,
    opLdElem_i4, opLdElem_u4, opLdElem_i8, opLdElem_i,
    opLdElem_r4, opLdElem_r8, opLdElem_ref,
    opStElem_i, opStElem_i1, opStElem_i2, opStElem_i4, opStElem_i8,
    opStElem_r4, opStElem_r8, opStElem_ref,
    opUnused2, opUnused3, opUnused4, opUnused5,
    opUnused6, opUnused7, opUnused8, opUnused9,
    opUnused10, opUnused11, opUnused12, opUnused13,
    opUnused14, opUnused15, opUnused16, opUnused17,
    opConv_ovf_i1, opConv_ovf_u1, opConv_ovf_i2, opConv_ovf_u2,
    opConv_ovf_i4, opConv_ovf_u4, opConv_ovf_i8, opConv_ovf_u8,
    opUnused50, opUnused18, opUnused19, opUnused20,
    opUnused21, opUnused22, opUnused23,
    opRefAnyVal, opCkFinite,
    opUnused24, opUnused25,
    opMkRefAny,
    opUnused59, opUnused60, opUnused61, opUnused62, opUnused63,
    opUnused64, opUnused65, opUnused66, opUnused67,
    opLdToken,
    opConv_u2, opConv_u1, opConv_i, opConv_ovf_i, opConv_ovf_u,
    opAdd_ovf, opAdd_ovf_un, opMul_ovf, opMul_ovf_un, opSub_ovf, opSub_ovf_un,
    opEndFinally, opLeave, opLeave_s, opStInd_i, opConv_u,
    opUnused26, opUnused27, opUnused28, opUnused29, opUnused30,
    opUnused31, opUnused32, opUnused33, opUnused34, opUnused35,
    opUnused36, opUnused37, opUnused38, opUnused39, opUnused40,
    opUnused41, opUnused42, opUnused43, opUnused44, opUnused45,
    opUnused46, opUnused47, opUnused48,
    opPrefix7, opPrefix6, opPrefix5, opPrefix4,
    opPrefix3, opPrefix2, opPrefix1, opPrefixRef,

    opArgLlist, opCeq, opCgt, opCgt_un, opClt, opClt_un,
    opLdFtn, opLdVirtFtn, optUnused56,
    opLdArg, opLdArga, opStArg, opLdLoc, opLdLoca, opStLoc,
    opLocalLoc, opUnused57, opEndFilter, opUnaligned, opVolatile,
    opTail, opInitObj, opUnused68, opCpBlk, opInitBlk, opUnused69,
    opRethrow, opUnused51, opSizeOf, opRefAnyType,
    opUnused52, opUnused53, opUnused54, opUnused55, opUnused70);

  TJclInstructionDumpILOption =
    (doLineNo, doRawBytes, doIL, doTokenValue, doComment);
  TJclInstructionDumpILOptions = set of TJclInstructionDumpILOption;

  TJclInstructionParamType =
   (ptVoid, ptI1, ptI2, ptI4, ptI8, ptU1, ptU2, ptU4, ptU8, ptR4, ptR8,
    ptToken, ptSOff, ptLOff, ptArray);

const
  InstructionDumpILAllOption =
    [doLineNo, doRawBytes, doIL, doTokenValue, doComment];

type
  TJclClrILGenerator = class;

  TJclInstruction = class(TObject)
  private
    FOpCode: TJclOpCode;
    FOffset: DWORD;
    FParam: Variant;
    FOwner: TJclClrILGenerator;
    function GetWideOpCode: Boolean;
    function GetRealOpCode: Byte;
    function GetName: string;
    function GetFullName: string;
    function GetDescription: string;
    function GetParamType: TJclInstructionParamType;
    function FormatLabel(Offset: Integer): string;
  protected
    function GetSize: DWORD; virtual;
    function DumpILOption(Option: TJclInstructionDumpILOption): string; virtual;
  public
    constructor Create(AOwner: TJclClrILGenerator; AOpCode: TJclOpCode);
    procedure Load(Stream: TStream); virtual;
    procedure Save(Stream: TStream); virtual;
    function DumpIL(Options: TJclInstructionDumpILOptions = [doIL]): string;
    property Owner: TJclClrILGenerator read FOwner;
    property OpCode: TJclOpCode read FOpCode;
    property WideOpCode: Boolean read GetWideOpCode;
    property RealOpCode: Byte read GetRealOpCode;
    property Param: Variant read FParam write FParam;
    property ParamType: TJclInstructionParamType read GetParamType;
    property Name: string read GetName;
    property FullName: string read GetFullName;
    property Description: string read GetDescription;
    property Size: DWORD read GetSize;
    property Offset: DWORD read FOffset;
  end;

  TJclUnaryInstruction = class(TJclInstruction);

  TJclBinaryInstruction = class(TJclInstruction);

  TJclClrILGenerator = class(TObject)
  private
    FMethod: TJclClrMethodBody;
    FInstructions: TObjectList;
    function GetInstructionCount: Integer;
    function GetInstruction(const Idx: Integer): TJclInstruction;
  public
    constructor Create(AMethod: TJclClrMethodBody = nil);
    destructor Destroy; override;
    function DumpIL(Options: TJclInstructionDumpILOptions): string;
    property Method: TJclClrMethodBody read FMethod;
    property Instructions[const Idx: Integer]: TJclInstruction read GetInstruction;
    property InstructionCount: Integer read GetInstructionCount;
  end;

  EJclCliInstructionError = class(EJclError);
  EJclCliInstructionStreamInvalid = class(EJclCliInstructionError);

implementation

uses
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF HAS_UNIT_VARIANTS}
  JclStrings, JclResources;

type
  TJclOpCodeInfoType = (itName, itFullName, itDescription);

const
  STP1 = $FE;

  OpCodeInfos: array [TJclOpCode, TJclOpCodeInfoType] of string =
   (
    ('nop',            RsCILCmdnop,         RsCILDescrnop),
    ('break',          RsCILCmdbreak,       RsCILDescrbreak),
    ('ldarg.0',        RsCILCmdldarg0,      RsCILDescrldarg0),
    ('ldarg.1',        RsCILCmdldarg1,      RsCILDescrldarg1),
    ('ldarg.2',        RsCILCmdldarg2,      RsCILDescrldarg2),
    ('ldarg.3',        RsCILCmdldarg3,      RsCILDescrldarg3),
    ('ldloc.0',        RsCILCmdldloc0,      RsCILDescrldloc0),
    ('ldloc.1',        RsCILCmdldloc1,      RsCILDescrldloc1),
    ('ldloc.2',        RsCILCmdldloc2,      RsCILDescrldloc2),
    ('ldloc.3',        RsCILCmdldloc3,      RsCILDescrldloc3),
    ('stloc.0',        RsCILCmdstloc0,      RsCILDescrstloc0),
    ('stloc.1',        RsCILCmdstloc1,      RsCILDescrstloc1),
    ('stloc.2',        RsCILCmdstloc2,      RsCILDescrstloc2),
    ('stloc.3',        RsCILCmdstloc3,      RsCILDescrstloc3),
    ('ldarg.s',        RsCILCmdldargs,      RsCILDescrldargs),
    ('ldarga.s',       RsCILCmdldargas,     RsCILDescrldargas),
    ('starg.s',        RsCILCmdstargs,      RsCILDescrstargs),
    ('ldloc.s',        RsCILCmdldlocs,      RsCILDescrldlocs),
    ('ldloca.s',       RsCILCmdldlocas,     RsCILDescrldlocas),
    ('stloc.s',        RsCILCmdstlocs,      RsCILDescrstlocs),
    ('ldnull',         RsCILCmdldnull,      RsCILDescrldnull),
    ('ldc.i4.m1',      RsCILCmdldci4m1,     RsCILDescrldci4m1),
    ('ldc.i4.0',       RsCILCmdldci40,      RsCILDescrldci40),
    ('ldc.i4.1',       RsCILCmdldci41,      RsCILDescrldci41),
    ('ldc.i4.2',       RsCILCmdldci42,      RsCILDescrldci42),
    ('ldc.i4.3',       RsCILCmdldci43,      RsCILDescrldci43),
    ('ldc.i4.4',       RsCILCmdldci44,      RsCILDescrldci44),
    ('ldc.i4.5',       RsCILCmdldci45,      RsCILDescrldci45),
    ('ldc.i4.6',       RsCILCmdldci46,      RsCILDescrldci46),
    ('ldc.i4.7',       RsCILCmdldci47,      RsCILDescrldci47),
    ('ldc.i4.8',       RsCILCmdldci48,      RsCILDescrldci48),
    ('ldc.i4.s',       RsCILCmdldci4s,      RsCILDescrldci4s),
    ('ldc.i4',         RsCILCmdldci4,       RsCILDescrldci4),
    ('ldc.i8',         RsCILCmdldci8,       RsCILDescrldci8),
    ('ldc.r4',         RsCILCmdldcr4,       RsCILDescrldcr4),
    ('ldc.r8',         RsCILCmdldcr8,       RsCILDescrldcr8),
    ('unused',         RsCILCmdunused1,     RsCILDescrunused1),
    ('dup',            RsCILCmddup,         RsCILDescrdup),
    ('pop',            RsCILCmdpop,         RsCILDescrpop),
    ('jmp',            RsCILCmdjmp,         RsCILDescrjmp),
    ('call',           RsCILCmdcall,        RsCILDescrcall),
    ('calli',          RsCILCmdcalli,       RsCILDescrcalli),
    ('ret',            RsCILCmdret,         RsCILDescrret),
    ('br.s',           RsCILCmdbrs,         RsCILDescrbrs),
    ('brfalse.s',      RsCILCmdbrfalses,    RsCILDescrbrfalses),