pax_pascal.pas

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

          Name[CurrToken.ID] := S;
      end;
    end;
  end;
end;

function TPAXPascalParser.Parse_OverloadableOperator: Integer;
begin
  if IsCurrText('=') then
    CurrToken.Text := '=='
  else if IsCurrText('<>') then
    CurrToken.Text := '!='
  else if IsCurrText('mod') then
    CurrToken.Text := '%'
  else if IsCurrText('shl') then
    CurrToken.Text := '<<'
  else if IsCurrText('shr') then
    CurrToken.Text := '>>';

  result := NewVar();
  Name[result] := CurrToken.Text;

  if OverloadableOperators.IndexOf(CurrToken.Text) = -1 then
    raise TPaxScriptFailure.Create(errOverloadableOperatorExpected);

  Call_SCANNER;
end;

function TPAXPascalParser.IsBaseType(const S: String): Boolean;
begin
  result := inherited IsBaseType(S);
  if result then
    Exit;
  result := (StrEql(S, 'TDateTime') or StrEql(S, 'Real'));
end;


destructor TPAXPascalParser.Destroy;
begin
  ForwardIds.Free;
  ForwardPos.Free;
  EnumIds.Free;

  OperCompare.Free;
  OperAdditive.Free;
  OperMult.Free;
  ConstIds.Free;

  inherited;
end;

procedure TPAXPascalParser.Reset;
begin
  inherited;

  if Assigned(ForwardIds) then
    ForwardIds.Clear;
  if Assigned(ForwardPos) then
    ForwardPos.Clear;
  if Assigned(EnumIds) then
    EnumIds.Clear;

  ConstIds.Clear;
end;

function TPAXPascalParser.Parse_EvalExpression: Integer;
begin
  result := Parse_Expression;
end;

function TPAXPascalParser.Parse_ArgumentExpression: Integer;
begin
  result := Parse_Expression;
end;

///////  EXPRESSIONS /////////////////////////////////////////////////////////

function TPAXPascalParser.Parse_ConstExpr: Integer;
begin
  result := Parse_Expression;
end;

function TPAXPascalParser.Parse_Expression: Integer;
var
  OP, TypeID: Integer;
  CallRec: TPaxCallRec;
begin
  result := Parse_SimpleExpression;
  if IsOperator(OperCompare, OP) then
  begin
    if OP = OP_TYPE_CAST then
    begin
      Gen(OP_PUSH, result, 0, 0);
      TypeID := Parse_Ident;
      result := NewVar;
      Gen(OP_CALL, TypeID, 1, result);

      CallRec := TPaxCallRec.Create;
      CallRec.CallP := Scanner.PosNumber;
      CallRec.CallN := Code.Card;
      TPaxBaseScripter(Scripter).CallRecList.AddObject(CallRec.CallN, CallRec);
    end
    else
    begin
      result := BinOp(OP, result, Parse_SimpleExpression);
      symboltable.PType[result] := typeBOOLEAN;
    end;
  end;
end;

function TPAXPascalParser.Parse_SimpleExpression: Integer;
var
  OP: Integer;
begin
  result := Parse_Term;
  while IsOperator(OperAdditive, OP) do
  begin
    if (OP = OP_OR) and ShortEvalSwitch and (TypeID[result] = typeBOOLEAN) then
    begin
      result := Parse_ShortEvalOR(result, Parse_Term, nil);
    end
    else
    begin
      result := BinOp(OP, result, Parse_Term);
    end;
  end;
end;

function TPAXPascalParser.Parse_Term: Integer;
var
  OP: Integer;
begin
  result := Parse_Factor;
  while IsOperator(OperMult, OP) do
  begin
    if (OP = OP_AND) and ShortEvalSwitch and (TypeID[result] = typeBOOLEAN) then
    begin
      result := Parse_ShortEvalAND(result, Parse_Factor, nil);
    end
    else
    begin
      result := BinOp(OP, result, Parse_Factor);
    end;
  end;
end;

function TPAXPascalParser.Parse_Factor: Integer;
var
  SubID, Vars: Integer;
  IsArrayItem: Boolean;
  CallRec: TPaxCallRec;
begin
  if IsTypeID then
  begin
    result := Parse_Ident;
    Match('(');
    Call_SCANNER;
    Parse_Expression;
    Match(')');
    Call_SCANNER;
  end
  else if IsCurrText('not') then
  begin
    Call_SCANNER;
    result := NewVar;
    Gen(OP_NOT, Parse_Factor, 0, result);
  end
  else if IsCurrText('-') then
  begin
    Call_SCANNER;
    result := NewVar;
    Gen(OP_UNARY_MINUS, Parse_Factor, 0, result);
  end
  else if IsCurrText('+') then
  begin
    Call_SCANNER;
    result := NewVar;
    Gen(OP_UNARY_PLUS, Parse_Factor, 0, result);
  end
  else if IsCurrText('/') then
    result := Parse_RegExpr('Create')
  else if IsConstant then
  begin
    result := CurrToken.ID;
    if TypeID[result] = typeSTRING then
    begin
      result := Parse_StringLiteral;
    end
    else
      Call_SCANNER;
  end
  else if IsCurrText('(') then
  begin
    Call_SCANNER;
    result := Parse_Expression;
    Match(')');
    Call_SCANNER;
  end
  else if IsCurrText('[') then
    result := Parse_SetConstructor
  else if IsCurrText('@') then
  begin
    result := NewVar;
    Call_SCANNER;
    if IsCallOperator then
      RemoveLastOperator;

    IsArrayItem := IsNextText('[') or IsNextText('(');;

    SubID := Parse_Designator;
    if IsCallOperator and (not IsArrayItem) then
       RemoveLastOperator;
    Gen(OP_ASSIGN_ADDRESS, result, SubID, result);
  end
  else if IsCurrText('inherited') then
  begin
    if CurrClassID = 0 then
      raise TPAXScriptFailure.Create(errStatementIsNotAllowedHere);
    if CurrSubID <> CurrMethodID then
      raise TPAXScriptFailure.Create(errStatementIsNotAllowedHere);

    FieldSwitch := true;
    Call_SCANNER;
    result := Parse_Ident;
    GenRef(CurrThisID, maMyBase, result);

    SubID := result;
    if IsCurrText('(') then
    begin
      Call_SCANNER;
      result := NewVar;
      Gen(OP_CALL, SubID, Parse_ArgumentList(SubID, Vars), result);
      SetVars(Vars);

      Match(')');
      Call_SCANNER;
    end
    else
    begin
      Gen(OP_CALL, SubID, 0, result);

      CallRec := TPaxCallRec.Create;
      CallRec.CallP := Scanner.PosNumber;
      CallRec.CallN := Code.Card;
      TPaxBaseScripter(Scripter).CallRecList.AddObject(CallRec.CallN, CallRec);
    end;
  end
  else
  begin // designator

{   if IsCurrText('new') then
    begin
      Call_SCANNER;
      ClassName := CurrToken.Text;
      ClassID := Parse_Ident;
      ObjectID := NewVar;

      Gen(OP_CREATE_OBJECT, ClassID, 0, ObjectID);

      result := NewRef;
      Gen(OP_CREATE_REF, ObjectID, NewConst(ClassName), result);
    end
    else }

    result := Parse_Designator;
  end;
end;

function TPAXPascalParser.Parse_Designator(ResID: Integer = 0): Integer;
var
  RefID, ID, Vars: Integer;
  ObjectID: Integer;
  CallRec: TPaxCallRec;
  K, Rank: Integer;
begin
  Vars := 0;

  if ResID = 0 then
  begin
    result := Parse_QualID;
    result := GenEvalWith(result);
  end
  else
    result := ResID;

  ID := result;  

  Rank := SymbolTable.Rank[result];
  while True do
    case CurrToken.Text[1] of
      '.':
      begin
        FieldSwitch := true;
        Call_SCANNER;

        if IsCurrText('Create') or IsCurrText('CreateNew') then
        begin
          ObjectID := NewVar;
          Gen(OP_CREATE_OBJECT, result, 0, ObjectID);
          result := Parse_Ident;
          GenRef(ObjectID, maAny, result);

          SymbolTable.PType[result] := ObjectID;
        end
        else
        begin
          if IsCurrText('free') then
          begin
            CurrToken.Text := 'Free';
            Name[CurrToken.ID] := 'Destroy';
          end;

          if IsKeyword(CurrToken.Text) then
          begin
            RefID := NewVar;
            Name[RefID] := CurrToken.Text;
            Call_SCANNER;
          end
          else
            RefID := Parse_Ident;
          GenRef(result, maAny, RefID);
          result := RefID;
        end;
        if not (CurrToken.Text[1] in ['(', '[']) then
        begin
          if Kind[ID] = KindVIRTUALOBJECT then
          begin
            ID := result;
            result := NewVar;
            Gen(OP_CALL, ID, 0, result);
          end
          else
            Gen(OP_CALL, result, 0, result);
        end;

{      if IsDestructor then
       begin
         Gen(OP_DESTROY_OBJECT, ObjectID, 0, 0);
         Gen(OP_CALL, 0, 0, 0);
       end;  }
      end;
      '[':
      begin
//        if Rank = -1 then
//          raise TPaxScriptFailure.Create(errCannotApplyToScalar);

        ID := result;
        result := NewVar;

        Call_SCANNER;
        K := Parse_ArgumentList(ID, Vars);
        Gen(OP_CALL, ID, K, result);
        SetVars(Vars);

        Match(']');

        if (Rank > 0) and (K <> Rank) then
           raise TPaxScriptFailure.Create(errRankMismatch);

        Call_SCANNER;
      end;
      '(':
      begin
        ID := result;
        result := NewVar;

        Call_SCANNER;
        if IsCurrText(')') then
        begin
          Gen(OP_CALL, ID, 0, result);

          CallRec := TPaxCallRec.Create;
          CallRec.CallP := Scanner.PosNumber;
          CallRec.CallN := Code.Card;
          TPaxBaseScripter(Scripter).CallRecList.AddObject(CallRec.CallN, CallRec);
        end
        else
        begin
          Gen(OP_CALL, ID, Parse_ArgumentList(ID, Vars), result);
        end;
        SetVars(Vars);
        Match(')');
        Call_SCANNER;
      end;
     '^':
      begin
        Call_SCANNER;
        ID := result;
        result := NewVar;
        Gen(OP_GET_TERMINAL, ID, 0, result);
      end;
      else
        Exit;
    end;
end;

function TPAXPascalParser.Parse_QualID: Integer;
begin
  if IsUnitID then
  begin
    Parse_Ident;
    Match('.');
    Call_SCANNER;
  end;

  result := Parse_Ident;
end;

function TPAXPascalParser.Parse_SetConstructor: Integer;
begin
  result := Parse_ArrayLiteral;
end;

function TPAXPascalParser.Parse_SetElement: Integer;
begin
  result := Parse_Expression;
  if IsCurrText('..') then
  begin
    Call_SCANNER;
    result := Parse_Expression;
  end;
end;

function TPAXPascalParser.Parse_UnitID: Integer;
begin
  result := Parse_Ident;
end;

function TPAXPascalParser.Parse_TypeID: Integer;
var
  S: String;
begin
  if IsCurrText('record') then
  begin
    result := NewVar;
    Kind[result] := KindTYPE;
    Parse_ClassStmt([], ckStructure, result);
    Exit;
  end;
  if IsCurrText('array') then
  begin
    result := NewVar;
    Name[result] := '__'+IntToStr(result);
    Kind[result] := KindTYPE;
    Parse_ArrayStmt(result);

    Exit;
  end;

  if IsCurrText('set') then
  begin
    result := typeSET;
    Call_SCANNER;

    if IsCurrText('of') then
    begin
      Call_SCANNER;
      Call_SCANNER;
    end;

    Exit;
  end;

  if IsCurrText('String') and IsNextText('[') then
    result := Parse_Ident
  else
    result := Parse_Designator;
  S := Name[result];

  if (result > PAXTypes.Count) or (result < 0) then
  begin
//    if Kind[result] <> KindTYPE then
//      raise TPAXScriptFailure.Create(Format(errTypeNotFound, [S]));
  end
  else
    if not (result in SupportedPaxTypes) then
    begin
      if StrEql(S, 'TextFile') or StrEql(S, 'File') then
      begin
        // ok
      end
      else
        raise TPAXScriptFailure.Create(Format(errTypeNotFound, [S]));
    end;
end;

function TPAXPascalParser.IsTypeID: boolean;
begin
  result := false;
end;

function TPAXPascalParser.IsConstant: boolean;
begin
  result := inherited IsConstant or IsCurrText('nil');
end;

function TPAXPascalParser.IsUnitId: boolean;
begin
  result := false;
end;

///////  STATEMENTS /////////////////////////////////////////////////////////

procedure TPAXPascalParser.Parse_Statement;
var
  ml: TPAXModifierList;
begin
  ml := [modPUBLIC];

  if IsLabelID then if Kind[CurrToken.ID] = KindLABEL then
  begin
    StatementLabel := CurrToken.Text;
    Parse_SetLabel;
    Match(':');
    Call_SCANNER;
  end;

  if IsCurrText('begin') then
  begin
    Parse_CompoundStmt;
    Call_SCANNER;

    if IsCurrText('.') then
      CurrToken.Text := ';';
  end
  else if IsCurrText('if') then
  begin
    IsExecutable := true;
    Parse_IfStmt;
    IsExecutable := false;
  end
  else if IsCurrText('namespace') then
    Parse_NamespaceStmt(ml)
  else if IsCurrText('function') then
  begin
    if LevelStack.KindTop <> KindSUB then
      ml := ml + [modSTATIC];
    Parse_FunctionStmt(tsGlobal, ml);
  end
  else if IsCurrText('procedure') then
  begin
    if LevelStack.KindTop <> KindSUB then
      ml := ml + [modSTATIC];
    Parse_FunctionStmt(tsGlobal, ml);
  end
  else if IsCurrText('constructor') then
    Parse_FunctionStmt(tsConstructor, ml)
  else if IsCurrText('destructor') then
    Parse_FunctionStmt(tsDestructor, ml)
  else if IsCurrText('var') then
  begin
    DeclareSwitch := true;
    Call_SCANNER;
    Parse_VarStmt(false, ml, false);
  end
  else if IsCurrText('const') then
  begin
    DeclareSwitch := true;
    Call_SCANNER;
    Parse_VarStmt(false, ml, true);
  end
  else if IsCurrText('class') then
    Parse_ClassStmt(ml, ckClass)
  else if IsCurrText('type') then
    Parse_TypeStmt
  else if IsCurrText('enum') then
    Parse_EnumStmt
  else if IsCurrText('record') then
    Parse_ClassStmt(ml, ckStructure)
  else if IsCurrText('case') then
    Parse_CaseStmt
  else if IsCurrText('repeat') then
  begin
    IsExecutable := true;
    Parse_RepeatStmt;
    IsExecutable := false;