base_parser.pas

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

  LocalVars := TPAXIds.Create(false);

  ShortEvalSwitch := true;
  SyntaxCheckOnly := false;
  JavaScriptOperators := false;
  ZeroBasedStrings := false;
  IsArrayInitialization := true;
  DeclareVariables := false;
  VBArrays := false;
  Backslash := true;
  DuplicateVars := false;

  Reset;
end;

destructor TPAXParser.Destroy;
begin
  Keywords.Free;
  LevelStack.Free;
  WithStack.Free;
  EntryStack.Free;
  UsingList.Free;
  Scanner.Free;
  TempObjectList.Free;
  ArrayArgumentList.Free;
  LocalVars.Free;

  inherited;
end;

procedure TPAXParser.Reset;
begin
  WithCount := 0;
  StatementLabel := '';
  DeclareSwitch := false;
  FieldSwitch := false;
  DirectiveSwitch := false;
  OptionExplicit := true;
  TempCount := 0;
  LevelStack.Clear;
  WithStack.Clear;
  EntryStack.Clear;
  UsingList.Clear;
  TempObjectList.Clear;
  ArrayArgumentList.Clear;
  LocalVars.Clear;
  BlockCount := 0;

  IsImplementationSection := false;
  IsExecutable := false;
  DuplicateVars := false;
end;

procedure TPAXParser.BeginBlock;
begin
  Inc(BlockCount);
end;

procedure TPAXParser.EndBlock;
begin
  Dec(BlockCount);
end;

procedure TPAXParser.SetScripter(AScripter: Pointer);
begin
  Reset;

  Scripter := AScripter;

  TPAXBaseScripter(Scripter).fLongStrLiterals := _Language.GetLongStrLiterals;

  SymbolTable := TPAXBaseScripter(Scripter).SymbolTable;
  ClassList := TPAXBaseScripter(Scripter).ClassList;
  Code := TPAXBaseScripter(Scripter).Code;

  Scanner.SetScripter(Scripter);
  Scanner.Reset;

  LevelStack.Clear;
  LevelStack.SetScripter(Scripter);
  LevelStack.Push(0);
  LevelStack.PushClass(SymbolTable.RootNamespaceID, 0, [modSTATIC], ckClass, true);

  UsingList.Clear;
end;

procedure TPAXParser.SetName(ID: Integer; const Value: String);
begin
  SymbolTable.Name[ID] := Value;
end;

function TPAXParser.GetName(ID: Integer): String;
begin
  result := SymbolTable.Name[ID];
end;

procedure TPAXParser.SetKind(ID: Integer; Value: Integer);
begin
  SymbolTable.Kind[ID] := Value;
end;

function TPAXParser.GetKind(ID: Integer): Integer;
begin
  result := SymbolTable.Kind[ID];
end;

procedure TPAXParser.SetAddress(ID: Integer; Value: Pointer);
begin
  SymbolTable.Address[ID] := Value;
end;

function TPAXParser.GetAddress(ID: Integer): Pointer;
begin
  result := SymbolTable.Address[ID];
end;

procedure TPAXParser.SetTypeID(ID: Integer; Value: Integer);
begin
  SymbolTable.PType[ID] := Value;
end;

function TPAXParser.GetTypeID(ID: Integer): Integer;
begin
  result := SymbolTable.PType[ID];
end;

procedure TPAXParser.SetCount(ID: Integer; Value: Integer);
begin
  SymbolTable.Count[ID] := Value;
end;

function TPAXParser.GetCount(ID: Integer): Integer;
begin
  result := SymbolTable.Count[ID];
end;

procedure TPAXParser.SetNext(ID: Integer; Value: Integer);
begin
  SymbolTable.Next[ID] := Value;
end;

function TPAXParser.GetNext(ID: Integer): Integer;
begin
  result := SymbolTable.Next[ID];
end;

procedure TPAXParser.SetTypeSub(SubID: Integer; Value: TPAXTypeSub);
begin
  SymbolTable.TypeSub[SubID] := Value;
end;

function TPAXParser.GetTypeSub(SubID: Integer): TPAXTypeSub;
begin
  result := SymbolTable.TypeSub[SubID];
end;

function TPAXParser.GetNameIndex(ID: Integer): Integer;
begin
  result := SymbolTable.NameIndex[ID];
end;

procedure TPAXParser.SetNameIndex(ID: Integer; Value: Integer);
begin
  SymbolTable.NameIndex[ID] := Value;
end;

procedure TPAXParser.SetVariant(ID: Integer; const Value: Variant);
begin
  SymbolTable.PutVariant(ID, Value);
end;

function TPAXParser.GetVariant(ID: Integer): Variant;
begin
  result := SymbolTable.GetVariant(ID);
end;

function TPAXParser.NewLabel: Integer;
begin
  with SymbolTable do
  begin
    result := AppLabel;
    Level[result] := CurrLevel;
    Module[result] := ModuleID;
  end;
end;

function TPAXParser.NewRef: Integer;
begin
  with SymbolTable do
  begin
    result := AppVariant(Undefined);
    Level[result] := CurrLevel;

    Inc(TempCount);
    Name[result] := '$$' + IntToStr(TempCount);
    Kind[result] := KindREF;
    Module[result] := ModuleID;
  end;
end;

function TPAXParser.NewVar: Integer;
begin
  with SymbolTable do
  begin
    result := AppVariant(Undefined);
    Level[result] := CurrLevel;
    Module[result] := ModuleID;

    Inc(TempCount);
    Name[result] := '$$' + IntToStr(TempCount);
  end;
end;

function TPAXParser.NewField(const FieldName: String): Integer;
begin
  with SymbolTable do
  begin
    result := AppVariant(Undefined);
    Level[result] := -1;
    Name[result] := FieldName;
    Module[result] := ModuleID;
  end;
end;

function TPAXParser.NewVar(const V: Variant): Integer;
begin
  with SymbolTable do
  begin
    result := AppVariant(V);
    Level[result] := CurrLevel;
    Module[result] := ModuleID;

    Inc(TempCount);
    Name[result] := '$$' + IntToStr(result);
  end;
end;

function TPAXParser.NewConst(const Value: Variant): Integer;
var
  I: Integer;
begin
  if VarType(Value) = varByte then
  begin
    I := Value;
    result := SymbolTable.AppVariantConst(I);
  end
  else
    result := SymbolTable.AppVariantConst(Value);
end;

function TPAXParser.Gen(Op, Arg1, Arg2, Res: Integer): Integer;
var
  _OP: Integer;
  b: boolean;
begin
  if JavaScriptOperators then
  begin
    if Op = OP_PLUS then
      Op := Op_PLUS_EX
    else if Op = OP_MINUS then
      Op := Op_MINUS_EX
    else if Op = OP_UNARY_MINUS then
      Op := Op_UNARY_MINUS_EX
    else if Op = OP_MULT then
      Op := Op_MULT_EX
    else if Op = OP_DIV then
      Op := Op_DIV_EX
    else if Op = OP_MOD then
      Op := Op_MOD_EX
    else if Op = OP_LEFT_SHIFT then
      Op := Op_LEFT_SHIFT_EX
    else if Op = OP_RIGHT_SHIFT then
      Op := Op_RIGHT_SHIFT_EX
    else if Op = OP_UNSIGNED_RIGHT_SHIFT then
      Op := Op_UNSIGNED_RIGHT_SHIFT_EX
    else if Op = OP_EQ then
      Op := Op_EQ_EX
    else if Op = OP_NE then
      Op := Op_NE_EX
    else if Op = OP_ID then
      Op := Op_ID_EX
    else if Op = OP_NI then
      Op := Op_NI_EX
    else if Op = OP_LT then
      Op := Op_LT_EX
    else if Op = OP_LE then
      Op := Op_LE_EX
    else if Op = OP_GT then
      Op := Op_GT_EX
    else if Op = OP_GE then
      Op := Op_GE_EX
    else if Op = OP_GO_FALSE then
      Op := Op_GO_FALSE_EX
    else if Op = OP_GO_TRUE then
      Op := Op_GO_TRUE_EX;
  end;

  if Op = OP_SET_TYPE then
    if IsBaseType(_GetName(Arg2, Scripter)) or (Arg2 = 0) then
    begin
      result := Code.Card;
      Exit;
    end;


  if
     (OP = OP_GO) or
//   (Op = OP_ASSIGN) or
     (OP = OP_PLUS) or (OP = OP_PLUS_EX) or
     (OP = OP_MINUS) or (OP = OP_MINUS_EX) or
     (OP = OP_MULT) or (OP = OP_MULT_EX) or
     (OP = OP_DIV) or (OP = OP_DIV_EX) or
     (OP = OP_INT_DIV) or
     (OP = OP_MOD) or (OP = OP_MOD_EX) or
     (OP = OP_AND) or
     (OP = OP_OR) or
     (OP = OP_XOR) or
     (OP = OP_LEFT_SHIFT) or (OP = OP_LEFT_SHIFT_EX) or
     (OP = OP_RIGHT_SHIFT) or (OP = OP_RIGHT_SHIFT_EX) or
     (OP = OP_UNSIGNED_RIGHT_SHIFT) or (OP = OP_UNSIGNED_RIGHT_SHIFT_EX) or
     (OP = OP_NOT) or
     (OP = OP_UNARY_MINUS) or (OP = OP_UNARY_MINUS_EX) or
     (OP = OP_GT) or (OP = OP_GT_EX) or
     (OP = OP_GE) or (OP = OP_GE_EX) or
     (OP = OP_LT) or (OP = OP_LT_EX) or
     (OP = OP_LE) or (OP = OP_LE_EX) or
     (OP = OP_EQ) or (OP = OP_EQ_EX) or
     (OP = OP_NE) or (OP = OP_NE_EX)
//     (OP = OP_ASSIGN_ADDRESS)
    then
    Code.RemoveNops;

  if OP = OP_ASSIGN then
  with Code do
  begin
    _OP := Prog[Card].Op;
    if Prog[Card].Res = Arg2 then
    begin
      b := false;
      b := b or (_OP = OP_PLUS) or (_OP = OP_PLUS_EX);
      b := b or (_OP = OP_MINUS) or (_OP = OP_MINUS_EX);
      b := b or (_OP = OP_MULT) or (_OP = OP_MULT_EX);
      b := b or (_OP = OP_DIV) or (_OP = OP_DIV_EX);
      b := b or (_OP = OP_INT_DIV);
      b := b or (_OP = OP_MOD) or (_OP = OP_MOD_EX);
      b := b or (_OP = OP_AND) or (_OP = OP_OR);
      b := b or    (_OP = OP_XOR);
      b := b or    (_OP = OP_LEFT_SHIFT) or (_OP = OP_LEFT_SHIFT_EX);
      b := b or    (_OP = OP_RIGHT_SHIFT) or (_OP = OP_RIGHT_SHIFT_EX);
      b := b or    (_OP = OP_UNSIGNED_RIGHT_SHIFT) or (_OP = OP_UNSIGNED_RIGHT_SHIFT_EX);

      b := b or    (_OP = OP_NOT);
      b := b or    (_OP = OP_UNARY_MINUS) or (_OP = OP_UNARY_MINUS_EX);

{     b := b or          (_OP = OP_GT) or (_OP = OP_GT_EX);
      b := b or          (_OP = OP_GE) or (_OP = OP_GE_EX);
      b := b or          (_OP = OP_LT) or (_OP = OP_LT_EX);
      b := b or          (_OP = OP_LE) or (_OP = OP_LE_EX);
      b := b or          (_OP = OP_EQ) or (_OP = OP_EQ_EX);
      b := b or          (_OP = OP_NE) or (_OP = OP_NE_EX); }

      b := b or (_OP = OP_ASSIGN_ADDRESS);

      if b then

        begin
          Prog[Card].Res := Arg1;
          result := Code.Card;
          Exit;
        end;
    end;
  end;

  Code.Add(Op, Arg1, Arg2, Res, IsExecutable);
  result := Code.Card;

  if Scanner.PosNumber = 0 then
    Code.Prog[result].LinePos := Scanner.PosNumber
  else
    Code.Prog[result].LinePos := Scanner.PosNumber - 1;

  if Op = OP_CALL then
  begin
    if Res <> 0 then
      if Kind[Arg1] = KindSUB then
        TypeID[Res] := TypeID[Arg1];
  end
  else if OP = OP_CREATE_OBJECT then
    TypeID[Res] := Arg1;
end;

procedure TPAXParser.GenAt(N: Integer; Op, Arg1, Arg2, Res: Integer);
begin
  Code.GenAt(N, Op, Arg1, Arg2, Res);
end;

procedure TPAXParser.GenRef(Arg1: Integer; ma: TPAXMemberAccess; Res: Integer);
begin
  while Code.Prog[Code.Card].Op = OP_NOP do
    Dec(Code.Card);
  Gen(OP_CREATE_REF, Arg1, Ord(ma), Res);
  SymbolTable.Kind[Res] := KindREF;
end;

function TPAXParser.IsCurrText(const S: String): boolean;
begin
  if UpCase then
    result := StrEql(CurrToken.Text, S)
  else
    result := CurrToken.Text = S;

  result := result and (CurrToken.TokenClass <> tcStringConst);
end;

function TPAXParser.IsNextText(const S: String): boolean;
begin
  if UpCase then
    result := StrEql(Scanner.NextToken.Text, S)
  else
    result := Scanner.NextToken.Text = S;
end;

function TPAXParser.IsNext2Text(const S: String): boolean;
begin
  if UpCase then
    result := StrEql(Scanner.Next2Token.Text, S)
  else
    result := Scanner.Next2Token.Text = S;
end;

function TPAXParser.Next2Text: String;
begin
  result := Scanner.Next2Token.Text;
end;

function TPAXParser.NextToken: TPAXToken;
begin
  result := Scanner.NextToken;
  if IsKeyword(result.Text) then
    result.TokenClass := tcKeyword;
end;

procedure TPAXParser.Match(const S: String);
begin
  if not IsCurrText(S) then
    raise TPAXScriptFailure.Create(Format(err_X_expected_but_Y_fond, [S, CurrToken.Text]));
end;

procedure TPAXParser.SetLabelHere(L: Integer);
begin
  if Code.Prog[Code.Card].Op = OP_PRINT_HTML then
    SymbolTable.PutVariant(L, Code.Prog[Code.Card].Res)
  else
    SymbolTable.PutVariant(L, Code.Card + 1);
end;

procedure TPAXParser.Call_SCANNER;
begin
  NewID := false;

  Scanner.ReadToken;
  CurrToken := Scanner.Token;

  if CurrToken.TokenClass = tcHtmlStringConst then
  begin
    GenHtml;
    Call_SCANNER;
    Exit;
  end;

  if CurrToken.TokenClass = tcId then
  begin
    if IsKeyword(CurrToken.Text) then
    begin
      CurrToken.TokenClass := tcKeyword;
      CurrToken.ID := 0;
    end;
  end;

  if CurrToken.TokenClass = tcSeparator then
    if CurrToken.ID <> SP_EOF then
    begin
      Gen(OP_SEPARATOR, ModuleID, CurrToken.ID, CurrLevel);
      Call_SCANNER;
      Exit;
    end;

  if FieldSwitch then
  begin
    CurrToken.ID := NewField(CurrToken.Text);
    CurrToken.TokenClass := tcID;
    SymbolTable.Position[CurrToken.ID] := CurrToken.Position - 1;

    FieldSwitch := false;
    Exit;
  end;

  if DirectiveSwitch then
  begin
    CurrToken.ID := SymbolTable.CodeStringConst(CurrToken.Text);
    DirectiveSwitch := false;
    Exit;
  end;

  case CurrToken.TokenClass of
    tcIntegerConst, tcFloatConst:
    begin
      CurrToken.ID := SymbolTable.CodeNumberConst(CurrToken.Value);
      if CurrToken.TokenClass = tcFloatConst then
        TypeID[CurrToken.ID] := typeDOUBLE;

      if JavaScriptOperators then
        TypeID[CurrToken.ID] := typeVARIANT;
      Exit;
    end;
    tcStringConst:
    begin
      CurrToken.ID := SymbolTable.CodeStringConst(CurrToken.Text);

      if JavaScriptOperators then
        TypeID[CurrToken.ID] := typeVARIANT;
      Exit;
    end;
    tcId:
    if DeclareSwitch then