base_parser.pas

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

////////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.                                  
// Code Version: 3.0
// ========================================================================
// Unit: BASE_PARSER.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////


{$I PaxScript.def}
unit BASE_PARSER;

interface

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils,
  Classes,
  BASE_CONSTS,
  BASE_SYS,
  BASE_SCANNER,
  BASE_SYMBOL,
  BASE_CLASS,
  BASE_CODE;

type
  TPAXParser = class;
  TPAXParserClass = class of TPAXParser;

  TPAXLevelStack = class(TPAXStack)
  private
    Parser: TPAXParser;
    ClassList: TPAXClassList;
    SymbolTable: TPAXSymbolTable;
    StateStack: TPAXStack;
  public
    constructor Create(Parser: TPAXParser);
    destructor Destroy; override;
    procedure SetScripter(AScripter: Pointer);
    function PushSub(SubID, ClassID: Integer; ml: TPAXModifierList): TPaxMemberRec;
    procedure PushClass(ClassID, AncestorClassID: Integer; ml: TPAXModifierList;
                        ck: TPAXClassKind; UpCase: Boolean);
    function PushTempClass: Integer;
    function KindTop: Integer;
    procedure Save;
    procedure Restore;
  end;

  TKeywordList = class(TStringList)
    function IndexOf(const S: string): Integer; override;
  end;

  TPaxBaseLanguage = class(TComponent)
  protected
    function GetLongStrLiterals: Boolean; virtual; abstract;
  end;

  TPAXParser = class
  private
    function GetName(ID: Integer): String;
    procedure SetName(ID: Integer; const Value: String);
    function GetKind(ID: Integer): Integer;
    procedure SetKind(ID: Integer; Value: Integer);
    function GetNameIndex(ID: Integer): Integer;
    procedure SetNameIndex(ID: Integer; Value: Integer);
    function GetVariant(ID: Integer): Variant;
    procedure SetVariant(ID: Integer; const Value: Variant);
    function GetAddress(ID: Integer): Pointer;
    procedure SetAddress(ID: Integer; Value: Pointer);
    procedure SetTypeID(ID: Integer; Value: Integer);
    function GetTypeID(ID: Integer): Integer;
    procedure SetCount(ID: Integer; Value: Integer);
    function GetCount(ID: Integer): Integer;
    procedure SetNext(ID: Integer; Value: Integer);
    function GetNext(ID: Integer): Integer;
    procedure SetTypeSub(SubID: Integer; Value: TPAXTypeSub);
    function GetTypeSub(SubID: Integer): TPAXTypeSub;
  public
    Scripter: Pointer;
    ModuleID: Integer;

    SymbolTable: TPAXSymbolTable;
    Scanner: TPAXScanner;
    ClassList: TPAXClassList;
    Code: TPAXCode;

    CurrToken: TPAXToken;
    UpCase: boolean;
    Keywords: TKeywordList;

    LevelStack: TPAXLevelStack;
    WithStack: TPAXWithStack;
    EntryStack: TPAXEntryStack;
    UsingList: TPAXUsingList;
    TempObjectList: TPAXIds;
    ArrayArgumentList: TPAXIds;
    LocalVars: TPAXIds;

    StatementLabel: String;

    TempCount: Integer;

    DeclareSwitch: boolean;
    FieldSwitch: boolean;
    DirectiveSwitch: boolean;
    OptionExplicit: Boolean;
    ShortEvalSwitch: Boolean;

    NewID: boolean;

    ArgumentListSwitch: Boolean;

    LanguageName, FileExt, IncludeFileExt: String;
    _Language: TPaxBaseLanguage;
    DefaultCallConv: Integer;
    NamespaceAsModule: Boolean;
    SyntaxCheckOnly: Boolean;
    JavaScriptOperators: Boolean;
    DeclareVariables: Boolean;
    IsArrayInitialization: Boolean;
    VBArrays: Boolean;
    ZeroBasedStrings: Boolean;
    Backslash: Boolean;

    BlockCount: Integer;

    IsImplementationSection: Boolean;
    IsExecutable: Boolean;

    DuplicateVars: Boolean;

    WithCount: Integer;

    constructor Create; virtual;
    destructor Destroy; override;
    procedure BeginBlock;
    procedure EndBlock;

    procedure SetScripter(AScripter: Pointer);
    procedure Reset; virtual;
    procedure AddExtraCode(const Key, StrCode: String);

    function NewLabel: Integer;
    function NewField(const FieldName: String): Integer;
    function NewVar: Integer; overload;
    function NewVar(const V: Variant): Integer; overload;
    function NewConst(const Value: Variant): Integer;
    function NewRef: Integer;
    function IsCurrText(const S: String): boolean;
    function IsNextText(const S: String): boolean;
    function IsNext2Text(const S: String): boolean;
    function NextToken: TPAXToken;
    function Next2Text: String;
    procedure Match(const S: String); virtual;
    procedure Call_SCANNER; virtual;

    function Gen(Op, Arg1, Arg2, Res: Integer): Integer; virtual;
    procedure GenAt(N: Integer; Op, Arg1, Arg2, Res: Integer);
    procedure LinkVariables(SubID: Integer; HasResult: Boolean);

    procedure GenRef(Arg1: Integer; ma: TPAXMemberAccess; Res: Integer);
    function GenEvalWith(ID: Integer): Integer;
    function InUsing(const MemberName: String): Integer;
    function GenBeginWith(ID: Integer): Integer;
    procedure GenEndWith(WithCount: Integer);
    procedure GenHtml;

    procedure SetLabelHere(L: Integer);
    function IsConstant: boolean; virtual;
    function IsKeyword(const S: String): boolean;
    function CurrLevel: Integer;
    function IsNestedSub(SubID: Integer): Boolean;
    function GetOuterSubID(SubID: Integer): Integer;
    function LookUpID(const Name: String): Integer;
    function LookUpLocalID(const Name: String): Integer;
    function IsLabelId: boolean;
    function LA(I: Integer): Char;
    function CurrClassID: Integer;
    function CurrMethodID: Integer;
    function CurrThisID: Integer;
    function CurrResultID: Integer;
    function CurrSubID: Integer;
    function CurrClassRec: TPAXClassRec;
    function ToInteger(ID: Integer): Integer;
    function ToBoolean(ID: Integer): Integer;
    function ToString(ID: Integer): Integer;
    function IsCallOperator(var Arg1, Arg2, Res: Integer): boolean; overload;
    function IsCallOperator: boolean; overload;
    function UndefinedID: Integer;
    procedure RemoveLastOperator;
    function LastCodeLine: Integer;
    procedure InsertCode(L1, L2: Integer);
    procedure SetVars(Vars: Integer);
//    function strIncompatibleTypes(T1, T2: Integer): String;
//    function MatchAssignment(ID1, ID2, ResID: Integer;
//                             RaiseException: Boolean = true;
//                             InitT1: Integer = 0;
//                             InitT2: Integer = 0): Integer;
//    procedure MatchTypes; virtual;
//    procedure MatchTheseTypes(S: TIntegerSet); virtual;
//    procedure CompareTypes; virtual;
    function Parse_ArgumentList(SubID: Integer; var Vars: Integer;
                                       CheckCall: Boolean = true;
                                       Erase: Boolean = true): Integer; virtual;
    function Parse_ArrayLiteral: Integer; virtual;
    procedure Parse_ObjectInitializer(ObjectID: Integer);
    procedure GenDestroyTempObjects;
    procedure GenDestroyArrayArgumentList;
    procedure GenDestroyLocalVars; virtual;
    function OpResultType(T1, T2: Integer): Integer;

    procedure Parse_Program; virtual; abstract;

    procedure Parse_ImportsStmt;
    function Parse_Rank: Integer;
    function Parse_ByRef: Integer;
    function Parse_SetLabel: Integer;
    function Parse_UseLabel: Integer;
    function Parse_Constant: Integer;
    function Parse_Ident: Integer;
    function Parse_OverloadableOperator: Integer; virtual;
    procedure Parse_GoToStmt;
    procedure Parse_PrintList;
    procedure Parse_PrintlnList;
    function Parse_StringLiteral: Integer;
    function Parse_CallConv: Integer;
    procedure Parse_ReducedAssignment(LeftID: Integer);
    function Parse_ShortEvalAND(ID: Integer;
                                Method0: TIntegerMethodNoParam;
                                Method1: TIntegerMethodOneParam): Integer;
    function Parse_ShortEvalOR(ID: Integer;
                               Method0: TIntegerMethodNoParam;
                               Method1: TIntegerMethodOneParam): Integer;

    function BinOp(OP, Arg1, Arg2: Integer): Integer;
    function IsOperator(OperList: TPAXIds; var OP: Integer): Boolean;
    procedure MoveUpSourceLine;
    function IsBaseType(const S: String): Boolean; virtual;
    procedure TestDupLocalVars(NewVarID: Integer);

    function Parse_RegExpr(const ConstructorName: String): Integer;
    function Parse_EvalExpression: Integer; virtual; abstract;
    function Parse_ArgumentExpression: Integer; virtual; abstract;
    procedure Parse_StmtList; virtual; abstract;
    property Name[ID: Integer]: String read GetName write SetName;
    property NameIndex[ID: Integer]: Integer read GetNameIndex write SetNameIndex;
    property Kind[ID: Integer]: Integer read GetKind write SetKind;
    property Value[ID: Integer]: Variant read GetVariant write SetVariant;
    property Address[ID: Integer]: Pointer read GetAddress write SetAddress;
    property TypeID[ID: Integer]: Integer read GetTypeID write SetTypeID;
    property Count[ID: Integer]: Integer read GetCount write SetCount;
    property Next[ID: Integer]: Integer read GetNext write SetNext;
    property TypeSub[ID: Integer]: TPAXTypeSub read GetTypeSub write SetTypeSub;
  end;

  TPAXParserList = class
  private
    fList: TList;
    function GetParser(I: Integer): TPAXParser;
    function GetName(I: Integer): String;
  public
    constructor Create;
    destructor Destroy; override;
    function Count: Integer;
    function IndexOf(P: TPAXParser): Integer;
    function Add(P: TPAXParser): Integer;
    function IndexOfLanguage(const LanguageName: String): Integer;
    function GetFileExt(const LanguageName: String): String;
    function GetLanguageName(const FileName: String): String;
    function FindParser(const LanguageName: String): TPAXParser;
    procedure RemoveParser(I: Integer);
    property Parsers[I: Integer]: TPAXParser read GetParser; default;
    property Names[I: Integer]: String read GetName;
  end;

implementation

uses
  BASE_SCRIPTER, BASE_EXTERN;

function TKeywordList.IndexOf(const S: string): Integer;
var
  I: Integer;
begin
  result := -1;
  for I:=0 to Count - 1 do
    if Strings[I] = S then
    begin
      result := I;
      Exit;
    end;
end;

constructor TPAXParserList.Create;
begin
  fList := TList.Create;
end;

destructor TPAXParserList.Destroy;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    Parsers[I].Free;

  fList.Free;
end;

function TPAXParserList.GetParser(I: Integer): TPAXParser;
begin
  result := fList[I];
end;

function TPAXParserList.IndexOf(P: TPAXParser): Integer;
begin
  result := fList.IndexOf(P);
end;

function TPAXParserList.Add(P: TPAXParser): Integer;
begin
  result := fList.Add(P);
end;

function TPAXParserList.Count: Integer;
begin
  result := fList.Count;
end;

function TPAXParserList.IndexOfLanguage(const LanguageName: String): Integer;
var
  I: Integer;
  P: TPAXParser;
begin
  result := -1;
  for I:=0 to fList.Count - 1 do
  begin
    P := Parsers[I];
    if StrEql(P.LanguageName, LanguageName) then
    begin
      result := I;
      Exit;
    end;
  end;
end;

function TPAXParserList.GetFileExt(const LanguageName: String): String;
var
  I: Integer;
  P: TPAXParser;
begin
  result := '';
  for I:=0 to fList.Count - 1 do
  begin
    P := Parsers[I];
    if StrEql(P.LanguageName, LanguageName) then
    begin
      result := P.FileExt;
      Exit;
    end;
  end;

  raise Exception.Create(errUnknownLanguage + LanguageName);
end;

function TPAXParserList.GetLanguageName(const FileName: String): String;
var
  I: Integer;
  P: TPAXParser;
  FileExt: String;
begin
  FileExt := UpperCase(ExtractFileExt(FileName));

  result := '';
  for I:=0 to fList.Count - 1 do
  begin
    P := Parsers[I];
    if StrEql(P.FileExt, FileExt) then
    begin
      result := P.LanguageName;
      Exit;
    end;
  end;

  raise Exception.Create(errIncorrectFileExtension + FileExt);
end;

function TPAXParserList.FindParser(const LanguageName: String): TPAXParser;
var
  I: Integer;
begin
  result := nil;
  I := IndexOfLanguage(LanguageName);
  if I = -1 then
    Exit;
  result := Parsers[I];
end;

procedure TPAXParserList.RemoveParser(I: Integer);
begin
  Parsers[I].Free;
  fList.Delete(I);
end;

function TPAXParserList.GetName(I: Integer): String;
begin
  result := Parsers[I].LanguageName;
end;

constructor TPAXLevelStack.Create(Parser: TPAXParser);
begin
  inherited Create;
  Self.Parser := Parser;
  StateStack := TPAXStack.Create;
end;

destructor TPAXLevelStack.Destroy;
begin
  StateStack.Free;
  inherited;
end;

procedure TPAXLevelStack.SetScripter(AScripter: Pointer);
begin
  ClassList := TPAXBaseScripter(AScripter).ClassList;
  SymbolTable := TPAXBaseScripter(AScripter).SymbolTable;
end;

function TPAXLevelStack.KindTop: Integer;
begin
  result := SymbolTable.Kind[Top];
end;

function TPAXLevelStack.PushSub(SubID, ClassID: Integer; ml: TPAXModifierList): TPaxMemberRec;
var
  IsNestedSub: Boolean;
  MemberRec: TPAXMemberRec;
  b: Boolean;
begin
  IsNestedSub := KindTop = KindSUB;

  Push(SubID);

  result := nil;

  if ClassID <> 0 then
    if not IsNestedSub then
    with Parser do
    begin
      if modSTATIC in CurrClassRec.ml then
        ml := ml + [modSTATIC];

      MemberRec := CurrClassRec.AddMethod(SubID, ml);

      result := MemberRec;

      if UpCase then
        b := StrEql(Name[SubID], 'Initialize')
      else
        b := Name[SubID] = 'Initialize';

      if b then
        MemberRec.InitN := 1;
    end;
end;

procedure TPAXLevelStack.PushClass(ClassID, AncestorClassID: Integer; ml: TPAXModifierList;
                                ck: TPAXClassKind; UpCase: Boolean);
var
  OwnerID: Integer;
begin
  OwnerID := 0;
  if Top <> 0 then
  begin
    Parser.CurrClassRec.AddNestedClass(ClassID, ml);
    OwnerID := Parser.CurrClassRec.ClassID;
  end;

  Push(ClassID);

  with SymbolTable do
    ClassList.AddClass(ClassID, Name[ClassID], Name[OwnerID], Name[AncestorClassID], ml, ck, UpCase);
end;

function TPAXLevelStack.PushTempClass: Integer;
begin
  result := Parser.NewVar;
  SymbolTable.Kind[result] := KindTYPE;
  PushClass(result, 0, [modSTATIC], ckClass, false);
end;

procedure TPAXLevelStack.Save;
begin
  StateStack.Push(Card);
end;

procedure TPAXLevelStack.Restore;
begin
  Card := StateStack.Pop;
end;

constructor TPAXParser.Create;
begin
  Scripter := nil;

  SymbolTable := nil;
  ClassList := nil;
  Code := nil;
  Scanner := nil;

  _Language := nil;

  ArgumentListSwitch := false;

  Keywords := TKeywordList.Create;
  LevelStack := TPAXLevelStack.Create(Self);
  WithStack := TPAXWithStack.Create;
  EntryStack := TPAXEntryStack.Create;
  UsingList := TPAXUsingList.Create;
  TempObjectList := TPAXIds.Create(false);
  ArrayArgumentList := TPAXIds.Create(false);