getunit.pas

一个Delphi解释器的例子

Unit getunit;

Interface
Uses
  delphin, dialogs, classes, sysutils;
{--------------------------------}
{ EXTERNAL OBJECT TYPES IMPORT

  You can use function ProcessUnit to import Delphi object types in HAL
  or add object types manually

  After importing add result unit to your project

  procedure processunit(const inname,outname,objlist:string;ImProcs:Boolean);

  inname  - full path to input unit
  outname - full path to output unit
  objlist - list of object names separated by coma
            (only these objects will be processed)
            (if objlist='' then all objects will be processed
  ImProcs - true   import procedures and functions
            false  no import of procedures and functions

  Unfortunately you have to modify output file in some cases
  (unit will not be compiled by Delphi without corrections)
  Please read modify.txt for details

}
{--------------------------------}
Type
  TUnitAn = Class(THalCompiler)
  Public
    UnitName: String;
    ClassesRead: TStringList;
    ClassesTypes: TStringList;
    ProcNames: TStringList;
    OnlyObj: TStringList;
    AST: TStringList;
    ProcessObj, ProcessFuns: Boolean;
    Function getpropparamlist: boolean;
    Function getpropinterf: String;
    Procedure propanalyze(Const pname: String);
    Procedure proceedvar(Const pname, vname, vtype: String);
    Procedure functionanalyze(Const cname: String; r: boolean); {r=true if function}
    Procedure getvariables(Const pname: String);
    Procedure classanalyze(Const cname: String);
    Procedure compile; override;
    Procedure unitnameanalyze;
    Constructor Create(M: TMemoryStream; AOnlyObj, MAST: TStringList);
    Destructor Destroy; override;
  End;
{--------------------------------}

Procedure processunit(Const inname, outname, objlist: String; ImProcs: Boolean);

{--------------------------------}

Implementation

{--------------------------------}

Procedure processunit(Const inname, outname, objlist: String; ImProcs: Boolean);
Var
  InpFile: TFileStream;
  InpMem: TMemoryStream;
  OutFile: TFileStream;
  OutUnitName: String;
  OutStrings: TStringList;
  Analyzer: TUnitAn;
  OnlyObjects: TStringList;
  i: integer;
Begin
  OutStrings := TStringList.Create;
  InpMem := TMemoryStream.Create;
  Analyzer := nil;
  OnlyObjects := nil;
  OutFile := nil;
  InpFile := nil;
  Try
    OnlyObjects := TStringList.Create;
    InpFile := TFileStream.Create(inname, fmopenread);
    OutFIle := TFileStream.Create(outname, fmcreate);
    OutUnitName := extractfilename(outname);
    OutUnitName := changefileext(outunitname, '');
    InpMem.CopyFrom(InpFile, InpFile.Size);
    Analyzer := TUnitAn.Create(InpMem, OnlyObjects, OutStrings);
    Analyzer.ProcessFuns := ImProcs;
    OnlyObjects.CommaText := AnsiUpperCase(objlist);
{--}
    With OutStrings do
    Begin
      Add('Unit ' + OutUnitName + ';');
      Add('Interface');
      Add('Uses Delphin, ');
      Add('Implementation');
      Add('{');
      Add('');

      Add('To Convert Variant to object use function VO()');
      Add('To Convert Object to variant use function OV()');

      Add('');
      Add('}');
      Add('');
      Analyzer.Compile;

      Add('');
      Add('Initialization');
      Add('');

{      For i := 0 to Analyzer.ClassesRead.Count - 1 do
      Begin
        Add('   AddObjectType(''' + Analyzer.ClassesRead[i] + ''', ''' +
          Analyzer.ClassesTypes[i] + '''); ');
      End;}

      Add('');

      For i := 0 to ANalyzer.ProcNames.Count - 1 do
        Add('   ' + ANalyzer.ProcNames[i]);

      Strings[2] := Strings[2] + Analyzer.UnitName + ';';
{------------}
      Add('');
      Add('End.');
    End;
{--}
    OutStrings.SaveToStream(OutFile);
    ShowMessage('Everything went OK!');
  Finally
    Analyzer.Free;
    InpFile.Free;
    InpMem.Free;
    OutFile.Free;
    OutStrings.Free;
    OnlyObjects.Free;
  End;
End;
{--------------------------------}

Constructor TUnitAn.Create(M: TMemoryStream; AOnlyObj, MAST: TStringList);
Begin
  Inherited Create(M, Nil);
  ClassesRead := TStringList.Create;
  ClassesTypes := TStringList.Create;
  OnlyObj := AOnlyObj;
  AST := MAST;
  ProcNames := TStringList.Create;
End;

{--------------------------------}

Destructor TUnitAn.Destroy;
Begin
  ClassesRead.Free;
  ClassesTypes.Free;
  ProcNames.Free;
  Inherited;
End;

{--------------------------------}

Procedure TUnitAn.unitnameanalyze;
Begin
  Token := Readtoken;
  UnitName := Token.Data;
  getdelimeter;
End;

{--------------------------------}

Procedure TUnitAn.functionanalyze(Const cname: String; r: boolean); {r=true if function}
Var
  mline, funname: String;
  ParamCount: Integer;
  Params: Array[0..100] of boolean;
  FunType: String;
  rt: integer;
{--}
  Procedure loadparameters;
  Var
    curmode: boolean;
    Label l1, l2;
  Begin
{while nexttoken.id<>idclosebracket do token:=readtoken;}
    l1:
      curmode := false;
    Case nexttoken.id of
      id_var:
        Begin
          Token := ReadToken;
          curmode := true;
          Goto l2;
        End;
      id_const:
        Begin
          token := readtoken; Goto l2;
        End;
      idclosebracket:
        exit;
      id_default, id_read, id_write, id_index, ididentifier:
        Begin
          l2: token := readtoken;
          params[paramcount] := curmode;
          inc(paramcount);
          If nexttoken.id = id2points then
          Begin
            Token := ReadToken;
            While (nexttoken.id <> iddelimeter) and
              (nexttoken.id <> idclosebracket)
              Do Token := readtoken; {type}
          End;
          If nexttoken.id = idcomma then
          Begin
            token := readtoken;
            Goto l2;
          End;
          If nexttoken.id = iddelimeter then
            token := readtoken;
          Goto l1;
        End;
    End;

  End;
{--}
Begin
  Token := ReadToken; {get prefix}
  Token := ReadToken;
  FunName := Token.Data;
  If ProcessObj then
    ProcessObj := (FunName[1] <> '_');
  ParamCount := 0;
  If nexttoken.id = idopenbracket then
  Begin
    getopenbracket;
    loadparameters;
    getclosebracket;
  End;
  If (r) then
  Begin
    If (NextToken.id=id2points) then
    begin
      Token := ReadToken; { get :}
      Token := Readtoken;
      FunType := Token.Data;
    end else
      FunType:='TObject';
  End;
  getdelimeter;
 {--}
  If (ProcessObj = false) then
    exit;
  With AST do
  Begin
    Add('{--------------------}');
    Add('function my' + Cname + FunName +
      '(slf:tobject;var s:array of variant):variant;');
    Add('begin');

    If Cname <> '' then
      mline := ' ' + Cname + '(slf).' + FunName
    Else
      mline := ' ' + FunName;

    If R then
    Begin
      mline := ' Result :=' + mline;
    End;

    If paramcount > 0 then
    Begin
      mline := mline + '(';
      For rt := 0 to paramcount - 1 do
      Begin
        mline := mline + 'S[' + inttostr(rt) + ']';
        If rt < paramcount - 1 then
          mline := mline + ',';
      End;
      mline := mline + ')';
    End;
    Mline := Mline + ';';
    Add(mline);
    Add('End;');
  End;

  If r = false then
    mline := 'AddProc('
  Else
    mline := 'AddFun(';
  If Cname = '' then
    mline := mline + '''' + FunName + ''', '+'my'+cname+funname+', ['
  Else
    mline := mline + '''' + Cname + '.' + FunName + ''', '+'my'+cname+funname+', [';

    If paramcount = 0 then
      mline := mline + '2'
    Else
    Begin
      For rt := 0 to paramcount - 1 do
      Begin
        If params[rt] then
          mline := mline + '1'
        Else
          mline := mline + '0';
        If rt < paramcount - 1 then
          mline := mline + ',';
      End;
    End;
    mline := mline + ']);';
    ProcNames.Add(mline);

End;
{--------------------------------}

Procedure TUnitAn.proceedvar(Const pname, vname, vtype: String);
Var
  mline: String;
Const cnm: Array[boolean] of string = ('get_', 'set_');
{--}

  Procedure mdk(f: boolean); {f=false when get}
  Begin
    With AST do
    Begin
      Add('Function ' + pname + cnm[f] + vname +
        '(slf:tobject;var s:array of variant):variant;');
      Add('Begin');
      mline := pname + '(slf).' + vname;
      If f = false then
        mline := '  Result := ' + mline + ';'
      Else
        mline := mline + ':=S[0];';
      Add(mline);
      Add('End;');
    End;
  End;
{--}
Begin
  mline := 'AddProp(''' + pname + '.' + vname + ''', '+
    pname + cnm[false] + vname + ',' + pname + cnm[true] + vname + ');';
  ProcNames.Add(mline);
  Ast.Add('{--------------------}');
  mdk(false);
  Ast.Add('');
  mdk(true);
End;

{--------------------------------}

Procedure TUnitAn.getvariables(Const pname: String);
Var
  w: Array[0..100] of string;
  wcount: integer;
  i: integer;
  Label l1;
Begin
  wcount := 0;
  l1:
    Token := Readtoken;
  w[wcount] := token.data;
  inc(wcount);
  If nexttoken.id = idcomma then
  Begin
    token := readtoken; Goto l1;
  End;
  token := readtoken; {:}
  token := readtoken; {type}
  getdelimeter;
  If ProcessObj then
    For i := 0 to wcount - 1 do proceedvar(pname, w[i], '');
End;
{--------------------------------}

Function TUnitAn.getpropparamlist: boolean;
Begin
  Result := false;
  If nexttoken.id = idsqopenbracket then
  Begin
    While token.id <> idsqclosebracket do token := readtoken;
    Result := true;
  End;
End;

{--------------------------------}

Function TUnitAn.getpropinterf: String;
Var
  aw: boolean;
Begin
  aw := getpropparamlist;
  token := readtoken; {:}
  token := readtoken;
  Result := token.data;
  If nexttoken.id = id_index then
  Begin
    token := readtoken;
    token := readtoken;
  End;
  If aw then
    Result := '';
End;

{--------------------------------}

Procedure TUnitAn.propanalyze(Const pname: String);
Var
  vname, vtype: String;
  Label l1;
Begin
  Token := ReadToken;
  Vname := token.data;
  If nexttoken.id <> iddelimeter then
  Begin
    Vtype := getpropinterf; If vtype = '' then
      VName := '';
  End
  Else
    vtype := '';
  While token.id <> iddelimeter do token := readtoken;
  If nexttoken.id = id_default then
  Begin
    token := readtoken;
    getdelimeter;
  End;
  If (length(vname) > 0) and (pos('ON', vname) <> 1) and (ProcessObj)
    Then
    proceedvar(pname, vname, vtype);
End;

{--------------------------------}

Procedure TUnitAn.classanalyze(Const cname: String);
Var
  CParent: String;
  r: integer;
  Label l1;
{--}

  Procedure myskip;
  Var
    k: integer;
    Label l1;
  Begin
    l1:
      k := nexttoken.id;
    If (k <> id_private) and
      (k <> id_protected) and
      (k <> id_public) and
      (k <> id_published) and
      (k <> id_end) then
    Begin
      Token := ReadToken; Goto l1;
    End;
  End;

{--}
Begin
  CParent := '';
  Token := ReadToken; {class read}
  Case nexttoken.id of
    iddelimeter:
      exit;
    ididentifier:
      exit;
    idopenbracket:
      Begin
        getopenbracket;
        Token := ReadToken;
        CParent := Token.Data;
        While Token.Id<>idclosebracket do
          Token:=ReadToken;
//        getclosebracket;
        If nexttoken.id = iddelimeter then
          exit;
      End;
    id_end:
      exit;
  End;
  If CParent = '' then
    CPAREnt := 'TOBJECT';

  If ProcessObj then
  Begin
    ClassesRead.Add(CName);
    ClassesTypes.Add(CParent);
  End;
  l1: r := nexttoken.id;
  Case r of
    id_private, id_protected:
      Begin
        Token := ReadToken; myskip;
        Goto l1;
      End;
    id_class, id_public, id_published:
      Begin
        Token := ReadToken;
        Goto l1;
      End;
    id_end:
      exit;
    ididentifier:
      Begin
        getvariables(cname);
        Goto l1;
      End;
    id_function, id_procedure, id_constr, id_destr:
      Begin
        functionanalyze(cname, (r = id_function) or (r = id_constr));
        getafterproc;
        Goto l1;
      End;
    id_property:
      Begin
        Token := ReadToken;
        propanalyze(cname);
             {myskip;}
        Goto l1;
      End;

  Else
    Begin
      Error('Token unknown:' + token.data); Goto l1;
    End;
  End;
End;

{--------------------------------}

Procedure TUnitAn.Compile;
Label l1;
Var
  VarName: String;
  u: integer;
  l: integer;
Begin
  l1:
    l := nextToken.ID;
  Case l of
    id_unit:
      Begin
        Token := ReadToken; unitnameanalyze; Goto l1;
      End;
    id_implement:
      exit;
    id_procedure, id_function:
      Begin
        ProcessObj := (ProcessFuns);
        functionanalyze('', l = id_function);
        getafterproc;
        Goto l1;
      End;
    id2points:
      Begin
        Token := ReadToken;
        Case nexttoken.id of
          id_procedure, id_function:
            token := readtoken;
        End;
        Goto l1;
      End;
    idequal:
      Begin
        VarName := Token.Data;
        Token := ReadToken;
        Case NextToken.ID of
          id_class:
            Begin
              ProcessObj := (OnlyObj.Count = 0) or (OnlyObj.Find(VarName, u));
              ClassAnalyze(VarName);
            End;
          id_function, id_procedure:
            token := readtoken;
        End;
        Goto l1;
      End;
  Else
    Begin
      Token := ReadToken; Goto l1;
    End;
  End;
End;

{--------------------------------}
End.