base_parser.pas

来自「Delphi脚本控件」· PAS 代码 · 共 2,625 行 · 第 1/5 页

      result := ClassRec.MemberList.GetMemberID(MemberName, UpCase);
      if result <> 0 then
        Exit;
    end;
  end;
end;

function TPAXParser.GenEvalWith(ID: Integer): Integer;

function IsScriptDefinedSubID(ID: Integer): Boolean;
var
  K: Integer;
begin
  result := false;
  if ID <= 0 then
    Exit;

  K := Kind[ID];
  if K = KindSUB then
    result := true;
end;

function IsParameterID(ID: Integer): Boolean;
var
  I, SubID, ParamID: Integer;
  Success: Boolean;
label Again;
begin
  result := false;
  SubID := LevelStack.Top;

Again:

  if SymbolTable.Kind[SubID] <> KindSUB then
    Exit;

  Success := false;
  with SymbolTable do
    for I:=1 to Count[SubID] do
    begin
      ParamID := GetParamID(SubID, I);

      if UpCase then
        Success := StrEql(Name[ParamID], Name[ID])
      else
        Success := Name[ParamID] = Name[ID];

      if Success then
      begin
        result := true;
        Exit;
      end;
   end;

  if not Success then
  begin
    SubID := GetOuterSubID(SubID);
    if SubID <= 0 then
      Exit;
    goto Again;
  end;
end;

function IsLocalVar(ID: Integer): Boolean;
var
  SubID: Integer;
begin
  result := false;
  SubID := CurrSubID;

  repeat
    if SubID <= 0 then
      Exit;
    result := (SymbolTable.Level[ID] = SubID) and SymbolTable.IsLocal(ID);

    if not result then
      SubID := GetOuterSubID(SubID)
    else
      Exit;
  until false;
end;

var
  K, MemberID: Integer;
  C: TPaxClassRec;
  nonstat: Boolean;
  neg: Boolean;
begin
  result := ID;

  K := Kind[ID];

  neg := ID < 0;

  if WithCount > 0 then
    neg := false;

  if not neg then
  if SymbolTable.Level[ID] <> 0 then
//  if (K <> KindCONST) and (K <> KindSUB) then
    if not IsParameterID(ID) then
    if not IsScriptDefinedSubID(ID) then
     if not IsLocalVar(ID) then
       if CurrThisID <> ID then
         if CurrResultID <> ID then
         begin
           MemberID := InUsing(Name[ID]);

           if MemberID <> 0 then
           begin
             if Kind[MemberID] = KindSUB then
               if Count[MemberID] = 0 then
               if not IsCurrText('(') then
               begin
                 result := NewVar;
                 Gen(OP_CALL, MemberID, 0, result);
                 Exit;
               end;
             if MemberID > 0 then
               Exit
             else
             begin
               result := NewVar;
               with SymbolTable do
               begin
                 Name[result] := Name[ID];
                 Level[result] := -1;
                 Module[result] := -1;
               end;
               Gen(OP_EVAL_WITH, 0, 0, result);
               Exit;
             end;
           end;

           Gen(OP_EVAL_WITH, 0, 0, ID);
           Exit;
         end;

  if K = KindSUB then
  if Count[ID] = 0 then if not IsCurrText('(') then if not IsCurrText(':=') then
  begin
    nonstat := false;
    for K:=2 to LevelStack.Card do
      if SymbolTable.Kind[LevelStack[K]] = KindTYPE then
      begin
        C := ClassList.FindClass(LevelStack[K]);
        if C <> nil then
          if not (modSTATIC in C.ml) then
            nonstat := true;
      end;

    if (SymbolTable.Kind[LevelStack.Top] = KindSUB) and nonstat then
    begin
      K := NewVar;
      with SymbolTable do
      begin
        Name[K] := Name[ID];
        Level[K] := -1;
        Module[K] := -1;
      end;
      Gen(OP_CREATE_REF, CurrThisId, 0, K);
      result := NewVar;
      Gen(OP_CALL, K, 0, result);
    end
    else
    begin
      result := NewVar;
      Gen(OP_CALL, ID, 0, result);
    end;
  end;
end;

function TPAXParser.GenBeginWith(ID: Integer): Integer;
var
  I, TempID: Integer;
begin
  result := 0;
  for I:=2 to LevelStack.Card do
  begin
    TempID := LevelStack[I];
    if TempID <> ID then
    if SymbolTable.Kind[TempID] = KindTYPE then
    begin
      Inc(result);
      Gen(OP_BEGIN_WITH, WithStack.Push(TempID), 0, 0);
    end;
  end;

  Gen(OP_BEGIN_WITH, WithStack.Push(ID), 0, 0);
  Inc(result);
end;

procedure TPAXParser.GenEndWith(WithCount: Integer);
var
  I: Integer;
begin
  for I:=1 to WithCount do
  begin
    Gen(OP_END_WITH, 0, 0, 0);
    WithStack.Pop;
  end;
end;

procedure TPAXParser.SetVars(Vars: Integer);
begin
  Code.Prog[Code.Card].Vars := Vars;
end;

procedure TPAXParser.AddExtraCode(const Key, StrCode: String);
begin
  if Scripter <> nil then
    TPAXBaseScripter(Scripter).ExtraCodeList.AddCode(Key, LanguageName, StrCode)
  else
    raise Exception.Create(errInternalError);
end;

procedure TPAXParser.LinkVariables(SubID: Integer; HasResult: Boolean);
begin
  SymbolTable.LinkVariables(SubID, HasResult);
end;

{
procedure TPAXParser.MatchTypes;
var
  T1, T2, ResType: Integer;
label
  Fin;
begin
  ResType := typeVARIANT;
  T1 := TypeID[Code.CurrArg1ID];
  T2 := TypeID[Code.CurrArg2ID];
  if T1 = T2 then
  begin
    ResType := T1;
    goto Fin;
  end;
  if T1 = typeVARIANT then
    goto Fin;
  if T2 = typeVARIANT then
    goto Fin;

  if OpResultType(T1, T2) > 0 then
  begin
    ResType := OpResultType(T1, T2);
    goto Fin;
  end;

  raise TPAXScriptFailure.Create(strIncompatibleTypes(T1, T2));
Fin:
  TypeID[Code.CurrResID] := ResType;
end;

procedure TPAXParser.CompareTypes;
var
  T1, T2: Integer;
begin
  TypeID[Code.CurrResID] := typeBOOLEAN;
  T1 := TypeID[Code.CurrArg1ID];
  T2 := TypeID[Code.CurrArg2ID];
  if T1 = T2 then
    Exit;
  if T1 = typeVARIANT then
    Exit;
  if T2 = typeVARIANT then
    Exit;
  if Abs(T1) > PaxTypes.Count then
    Exit;
  if Abs(T2) > PaxTypes.Count then
    Exit;
  if OpResultType(T1, T2) > 0 then
    Exit;
  raise TPAXScriptFailure.Create(strIncompatibleTypes(T1, T2));
end;

function TPAXParser.MatchAssignment(ID1, ID2, ResID: Integer;
                                    RaiseException: Boolean = true;
                                    InitT1: Integer = 0;
                                    InitT2: Integer = 0): Integer;
var
  T1, T2, ResType: Integer;
label
  Fin;
begin
  ResType := typeVARIANT;
  result := ID2;

  if InitT1 = 0 then
    T1 := TypeID[ID1]
  else
    T1 := InitT1;

  if InitT2 = 0 then
    T2 := TypeID[ID2]
  else
    T2 := InitT2;

  if T1 = T2 then
  begin
    ResType := T1;
    goto Fin;
  end;

  if T1 = typeVARIANT then
  begin
    ResType := T2;
    goto Fin;
  end;

  if T2 = typeVARIANT then
    goto Fin;

  if T1 > PAXTypes.Count then
    goto Fin;

  if T2 > PAXTypes.Count then
    goto Fin;

  if T1 < 0 then
    goto Fin;

  if T2 < 0 then
    goto Fin;

  if AssResultTypes[T1, T2] then
  begin
    ResType := T1;
    goto Fin;
  end;

  TPaxBaseScripter(Scripter).Dump;

  if RaiseException then
    raise TPAXScriptFailure.Create(strIncompatibleTypes(T1, T2))
  else
  begin
    result := 0;
    Exit;
  end;
Fin:
  if ResID > 0 then
    if ResTYPE <> typeVARIANT then
      TypeID[ResID] := ResType;
end;


procedure TPAXParser.MatchTheseTypes(S: TIntegerSet);
var
  T1: Integer;
begin
  T1 := TypeID[Code.CurrArg1ID];
  if T1 <= PAXTypes.Count then
    if T1 in (S + [typeVARIANT]) then
    begin
      TypeID[Code.CurrResID] := T1;
      Exit;
    end;
  raise TPAXScriptFailure.Create(errOperatorNotApplicable);
end;

function TPAXParser.strIncompatibleTypes(T1, T2: Integer): String;
begin
  result := Format(errIncompatibleTypesExt, [Name[T1], Name[T2]]);
end;
}

function TPAXParser.Parse_ArgumentList(SubID: Integer; var Vars: Integer;
                                       CheckCall: Boolean = true;
                                       Erase: Boolean = true): Integer;
var
  CallRec: TPaxCallRec;

procedure _ParseExpr;
var
  ID, ExprID: Integer;
begin
  Inc(result);

  ExprID := Parse_ArgumentExpression;

  if Kind[ExprID] = KindCONST then
  begin
    ID := NewVar;
    Gen(OP_ASSIGN, ID, ExprID, ID);
    TypeID[ID] := TypeID[ExprID];
  end
  else
  begin
    ID := ExprID;
    SetBit(Vars, result);
  end;

  Gen(OP_PUSH, ID, result, SubID);

  if CheckCall then
  begin
    CallRec.ArgsN.Add(Code.Card);
    CallRec.ArgsP.Add(Scanner.PosNumber);
  end;
end;

var
  I: Integer;
  S: String;
begin
  Vars := 0;
  result := 0;

  ArgumentListSwitch := true;

  if CheckCall then
  begin
    CallRec := TPaxCallRec.Create;
    CallRec.CallP := Scanner.PosNumber;
  end;

  _ParseExpr;
  while IsCurrText(',') do
  begin
    Call_SCANNER;
    _ParseExpr;
  end;

  if CheckCall then
  begin
    CallRec.CallN := Code.Card + 1;
    TPaxBaseScripter(Scripter).CallRecList.AddObject(CallRec.CallN, CallRec);
  end;

  ArgumentListSwitch := false;
  if Erase then
  begin
    S := Name[SubId];
    I := ArrayParamMethods.IndexOf(S);
    if I = -1 then
      ArrayArgumentList.Clear;
  end;
end;

procedure TPAXParser.GenDestroyTempObjects;
var
  I, ID: Integer;
begin
  for I := TempObjectList.Count - 1 downto 0 do
  begin
    ID := TempObjectList[I];
    Gen(OP_DESTROY_OBJECT, ID, 0, 0);
  end;
  TempObjectList.Clear;
end;

procedure TPAXParser.GenDestroyArrayArgumentList;
var
  I, ID: Integer;
begin
  for I := ArrayArgumentList.Count - 1 downto 0 do
  begin
    ID := ArrayArgumentList[I];
    Gen(OP_DESTROY_OBJECT, ID, 0, 0);
  end;
  ArrayArgumentList.Clear;
end;

procedure TPAXParser.GenDestroyLocalVars;
var
  I, ID, SubID: Integer;
begin
  SubID := LevelStack.Top;
  for I := LocalVars.Count - 1 downto 0 do
  begin
    ID := LocalVars[I];
    if SymbolTable.Level[ID] = SubID then
    begin
      Gen(OP_DESTROY_LOCAL_VAR, ID, 0, 0);
      LocalVars.Delete(I);
    end;
  end;
end;

function TPAXParser.OpResultType(T1, T2: Integer): Integer;
begin
  result := 0;
  if T1 > PAXTypes.Count then
    Exit;
  if T2 > PAXTypes.Count then
    Exit;
  result := OpResultTypes[T1, T2];
  if result = 0 then
    result := OpResultTypes[T2, T1];
end;

function TPAXParser.Parse_RegExpr(const ConstructorName: String): Integer;
var
  S: String;
  I, RegExpID, CreateID, SourceID, ExprID, ID: Integer;
begin
  S := Scanner.GetRegExpr;

  RegExpID := NewVar;
  Name[RegExpID] := 'RegExp';

  CreateID := NewVar;
  Name[CreateID] := ConstructorName;

  SourceID := NewVar;
  Name[SourceID] := 'source';

  ExprID := NewConst(S);

  result := NewVar;

  Gen(OP_EVAL_WITH, 0, 0, RegExpID);
  Gen(OP_CREATE_OBJECT, RegExpID, Integer(maAny), result);
  GenRef(result,  maAny, CreateID);
  Gen(OP_CALL, CreateID, 0, result);

  GenRef(result, MaAny, SourceID);
  Gen(OP_PUSH, ExprID, 0, 0);
  Gen(OP_PUT_PROPERTY, SourceID, 1, 0);

  Call_SCANNER;
  Match('/');

  if LA(1) in ['i', 'I', 'g', 'G', 'm', 'M'] then
  begin
    Call_SCANNER;