unit1.pas

Delphi脚本控件

          begin
            S := S + 'AsString';
            types := types + 'typeSTRING';
          end
          else if P.Types[I] = P.typBOOLEAN then
          begin
            S := S + 'AsBoolean';
            types := types + 'typeBOOLEAN';
          end
          else if P.Types[I] = P.typINTEGER then
          begin
            S := S + 'AsInteger';
            types := types + 'typeINTEGER';
          end
          else if P.Types[I] = P.typDOUBLE then
          begin
            S := S + 'AsDouble';
            types := types + 'typeDOUBLE';
          end
          else
          begin
            S := S + 'PValue^';
            SignEx := false;
          end;

          if I < P.NP then
            S := S + ',';
        end;

        S := S + ');';
        ExtraCode.Add(S);
        ExtraCode.Add('end;');

        if (Types <> '') and (TypeRes <> '') then
          Types := Types + ',';

        if SignEx then
        begin
          if UserData = '' then
            AddLine('RegisterStdRoutineEx(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ',[' + Types + TypeRes + ']' +
                   ', H);')
          else
            AddLine('RegisterStdRoutineEx(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ',[' + Types + TypeRes + ']' +
                   ', H, ' + UserData + ');');
        end
        else
        begin
          if UserData = '' then
            AddLine('RegisterStdRoutine(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ', H);')
          else
            AddLine('RegisterStdRoutine(' +
                   StringConst(E.Name) + ', _' + FakeName + ',' + IntToStr(P.NP) +
                   ', H, ' + UserData + ');');
        end;
      end
      else
      begin

        if PosOver > 0 then
        begin
          S := Copy(E.Declaration, 1, PosOver - 1);
          S := StringReplace(S, E.Name, FakeName, [rfIgnoreCase]);

          ExtraCode.Add(S);
          ExtraCode.Add('begin');
          S := '  result := ' + SourceUnitName + '.' + E.Name + '(';
          for I:=0 to P.ParamList.Count - 1 do
          begin
            S := S + P.ParamList[I];
            if I < P.ParamList.Count - 1 then
              S := S + ',';
          end;
          S := S + ');';
          ExtraCode.Add(S);
          ExtraCode.Add('end;');

          if UserData = '' then
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + FakeName + ', H);')
          else
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + FakeName +
                   ', H, ' + UserData + ');');
        end
        else
        begin
          if UserData = '' then
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + E.Name + ', H);')
          else
            AddLine('RegisterRoutine(' +
                   StringConst(E.Declaration) + ', @' + E.Name +
                   ', H, ' + UserData + ');');
        end;
      end;
    finally
      P.Free;
      VisitedRoutines.Add(FakeName);
    end;
  end;
end;

procedure TForm1.WDelphiParser1ClassFunctionEntry(aEntry: TEntry;
  aAddEntry: Boolean);
var
  E: TClassFunctionEntry;
  P: TSimpleParser;
  S, TypeRes, Types: String;
  I: Integer;
  SignEx: Boolean;
  PosOver: Integer;
  FakeName: String;
begin
  EndOfUsesClause;

  if CurrentClass = '' then
    Exit;

  E := TClassFunctionEntry(aEntry);

  if not IsValidClassFunctionEntry(E) then
    Exit;

  if not ValidConst(E.Declaration) then Exit;

  P := TSimpleParser.Create;
  try
    PosOver := Pos('OVERLOAD', UpperCase(E.Declaration));

    if PosOver > 0 then
    begin
      Inc(OverCount);
      FakeName := E.Name + IntToStr(OverCount);
    end
    else
      FakeName := E.Name;

    P.Parse_Header(E.Declaration);

    if RadioButton2.Checked then
      P.Fail := true;

    if body = bInterface then
      P.Fail := true;

    if not P.Fail then
    begin
      ExtraCode.Add('procedure ' +
        CurrentClass + '_' + FakeName + '(MethodBody: TPAXMethodBody);');
      ExtraCode.Add('begin');
      ExtraCode.Add('  with MethodBody do');

      TypeRes := '';
      Types := '';
      SignEx := true;

      if P.IsFunction then
      begin
        if P.TypeRes = P.typCARDINAL then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typDWORD then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typUINT then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typBYTE then
        begin
          S := '   result.AsInteger := ';
          TypeRes := 'typeINTEGER';
        end
        else if P.TypeRes = P.typEXTENDED then
        begin
          S := '   result.AsDouble := ';
          TypeRes := 'typeDOUBLE';
        end
        else if P.TypeRes = P.typSINGLE then
        begin
          S := '   result.AsDouble := ';
          TypeRes := 'typeDOUBLE';
        end
        else if P.TypeRes = P.typPOINTER then
        begin
          S := '   result.AsPointer := ';
          TypeRes := 'typePOINTER';
        end
        else if P.TypeRes = P.typSTRING then
        begin
          S := '   result.AsString := ';
          TypeRes := 'typeSTRING';
        end
        else if P.TypeRes = P.typBOOLEAN then
        begin
          S := '   result.AsBoolean := ';
          TypeRes := 'typeBOOLEAN';
        end
        else if P.TypeRes = P.typINTEGER then
        begin
          S := '   result.AsInteger := ';
          TypeRes := 'typeINTEGER';
        end
        else if P.TypeRes = P.typDOUBLE then
        begin
          S := '   result.AsDouble := ';
          TypeRes := 'typeDOUBLE';
        end
        else
        begin
          S := '   result.PValue^ := ';
          SignEx := false;
        end;
      end
      else
        S := '';

      S := S + CurrentClass + '(Self).';

      S := S + E.Name + '(';
      for I:=1 to P.NP do
      begin
        S := S + 'Params[' + IntToStr(I-1) + '].';

        if I > 1 then types := types + ',';

        if P.Types[I] = P.typCARDINAL then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typDWORD then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typUINT then
        begin
          S := S + 'AsCardinal';
          types := types + 'typeCARDINAL';
        end
        else if P.Types[I] = P.typBYTE then
        begin
          S := S + 'AsInteger';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typEXTENDED then
        begin
          S := S + 'AsDouble';
          types := types + 'typeDOUBLE';
        end
        else if P.Types[I] = P.typSINGLE then
        begin
          S := S + 'AsDouble';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typPOINTER then
        begin
          S := S + 'AsPointer';
          types := types + 'typePOINTER';
        end
        else if P.Types[I] = P.typSTRING then
        begin
          S := S + 'AsString';
          types := types + 'typeSTRING';
        end
        else if P.Types[I] = P.typBOOLEAN then
        begin
          S := S + 'AsBoolean';
          types := types + 'typeBOOLEAN';
        end
        else if P.Types[I] = P.typINTEGER then
        begin
          S := S + 'AsInteger';
          types := types + 'typeINTEGER';
        end
        else if P.Types[I] = P.typDOUBLE then
        begin
          S := S + 'AsDouble';
          types := types + 'typeDOUBLE';
        end
        else
        begin
          S := S + 'PValue^';
          SignEx := false;
        end;

        if I < P.NP then
          S := S + ',';
      end;
      S := S + ');';
      ExtraCode.Add(S);
      ExtraCode.Add('end;');

      if (Types <> '') and (TypeRes <> '') then
        Types := Types + ',';

      if SignEx then
      begin
        if UserData = '' then
          AddLine('RegisterStdMethodEx(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) +
                 ',[' + Types + TypeRes + ']' +
                 ');')
        else
          AddLine('RegisterStdMethodEx(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) +
                 ',[' + Types + TypeRes + '], ' +
                 UserData + ');');
       end
      else
      begin
        if UserData = '' then
          AddLine('RegisterStdMethod(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) + ');')
        else
          AddLine('RegisterStdMethod(' + CurrentClass + ',' +
                 StringConst(E.Name) + ',' +
                 CurrentClass + '_' + FakeName + ',' + IntToStr(P.NP) + ', ' + UserData + ');');

      end;
    end
    else
    begin
      if body = bInterface then
      begin
//      AddLine('RegisterInterfaceMethod(TypeInfo(' + CurrentClass + '),');


        AddLine('RegisterInterfaceMethod(' + CurrentClass + ',');

        if UserData = '' then
          AddLine(Space(5) + StringConst(E.Declaration) + ');')
        else
          AddLine(Space(5) + StringConst(E.Declaration) + ', - 1, ' + UserData + ');');
      end
      else if PosOver > 0 then
      begin
      end
      else
      begin
        AddLine('RegisterMethod(' + CurrentClass + ',');
        AddLine(Space(5) + StringConst(E.Declaration) + ',');

        if UserData = '' then
          AddLine(Space(5) + '@' + CurrentClass + '.' + E.Name + ');')
        else
          AddLine(Space(5) + '@' + CurrentClass + '.' + E.Name + ', false,' + UserData + ');');
      end;
    end;
  finally
    P.Free;
  end;

end;

procedure TForm1.WDelphiParser1ClassProcedureEntry(aEntry: TEntry;
  aAddEntry: Boolean);
var
  E: TClassProcedureEntry;
  P: TSimpleParser;
  S, TypeRes, Types: String;
  I: Integer;
  SignEx: Boolean;
  PosOver: Integer;
  FakeName: String;
begin
  EndOfUsesClause;

  if CurrentClass = '' then
    Exit;

  E := TClassProcedureEntry(aEntry);

  if not IsValidClassProcedureEntry(E) then
    Exit;

  if not ValidConst(E.Declaration) then Exit;

  P := TSimpleParser.Create;
  try
    PosOver := Pos('OVERLOAD', UpperCase(E.Declaration));

    if PosOver > 0 then
    begin
      Inc(OverCount);
      FakeName := E.Name + IntToStr(OverCount);
    end
    else
      FakeName := E.Name;

    P.Parse_Header(E.Declaration);

    if RadioButton2.Checked then
      P.Fail := true;

    if body = bInterface then
      P.Fail := true;

    if not P.Fail then
    begin
      ExtraCode.Add('procedure ' +
        CurrentClass + '_' + FakeName + '(MethodBody: TPAXMethodBody);');
      ExtraCode.Add('begin');
      ExtraCode.Add('  with MethodBody do');

      TypeRes := '';
      Types := '';
      SignEx := true;

      if P.IsFunction then
      begin
        if P.TypeRes = P.typCARDINAL then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typDWORD then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typUINT then
        begin
          S := '   result.AsCardinal := ';
          TypeRes := 'typeCARDINAL';
        end
        else if P.TypeRes = P.typBYTE then
        begin
          S := '   result.AsInteger := ';
          TypeRes := 'typeINTEGER';
        end
        else if P.TypeRes = P.typEXTENDED then
        begin
          S := '   result.AsDouble := ';
          TypeRes := 'typeDOUBLE';
        end
        else if P.TypeRes = P.typSINGLE then
        begin
          S := '   result.AsDouble := ';
          TypeRes := 'typeDOUBLE';
        end
        else if P.TypeRes = P.typPOINTER then
        begin
          S := '   result.AsPointer := ';
          TypeRes := 'typePOINTER';
        end
        else if P.TypeRes = P.typSTRING then
        begin
          S := '   result.AsString := ';
          TypeRes := 'typeSTRING';
        end
        else if P.TypeRes = P.typBOOLEAN then
        begin
          S := '   result.AsBoolean := ';
          TypeRes := 'typeBOOLEAN';
        end
        else if P.TypeRes = P.typINTEGER then
        begin
          S := '   result.AsInteger := ';
          TypeRes := 'typeINTEGER';
        end
        else if P.TypeRes = P.typDOUBLE then
        begin
          S := '   result.AsDouble := ';