dxjs_parser.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_PARSER
//       Author: Alexander Baranovsky ([e-mail])
//               G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 2002, 2004
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
// Code Version: (3rd Generation)
// ========================================================================
//  Description: parse the supplied script source code into our token code
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_PARSER;

interface

uses
   Classes,
   DXJS_SHARE,
   DXJS_LIST;

type
   TParser=class
      JScript:Pointer;
      CurrToken:TToken;
      CurrLevel:Integer;
      EntryStack:TEntryStack;
      StatementLabel:string;
      NewID,IsFormalParameter,IsDeclareSwitch:boolean;
      FuncDecl:string;
      WithStack:Integer;
      IncList,DecList:TList;
      constructor Create (aJScript:Pointer) ;
      destructor Destroy;override;
      procedure App_POSTFIX (Const I:Integer) ;
      procedure Call_SCANNER (FieldID:boolean=false) ;
      function NextToken:TToken;
      procedure Match (I:Integer) ;
      function AppLabel:Integer;
      procedure SetLabelHere (Const L:Integer) ;
      function AppConstant (const Value:Variant) :Integer;
      procedure AppIncList (Const K:Integer) ;
      procedure AppDecList (Const K:Integer) ;
// Expressions
      function Parse_Identifier:Integer;
      procedure Parse_PrimaryExpression;
      procedure Parse_ArrayLiteral;
      procedure Parse_ObjectLiteral;
      procedure Parse_MemberExpression;
      procedure Parse_NewExpression;
      function Parse_Arguments:Integer;
      function Parse_ArgumentList:Integer;
      procedure Parse_LeftHandSideExpression;
      procedure Parse_PostfixExpression (Const Left:boolean) ;
      procedure Parse_UnaryExpression (Const Left:boolean) ;
      procedure Parse_MultiplicativeExpression (Const Left:boolean) ;
      procedure Parse_AdditiveExpression (Const Left:boolean) ;
      procedure Parse_ShiftExpression (Const Left:boolean) ;
      procedure Parse_RelationalExpression (Const Left:boolean) ;
      procedure Parse_EqualityExpression (Const Left:boolean) ;
      procedure Parse_BitwiseANDExpression (Const Left:boolean) ;
      procedure Parse_BitwiseXORExpression (Const Left:boolean) ;
      procedure Parse_BitwiseORExpression (Const Left:boolean) ;
      procedure Parse_LogicalANDExpression (Const Left:boolean) ;
      procedure Parse_LogicalORExpression (Const Left:boolean) ;
      procedure Parse_ConditionalExpression (Const Left:boolean) ;
      procedure Parse_AssignmentExpression;
      function Parse_AssignmentOperator:Integer;
      procedure Parse_Expression;
// Statements
      procedure Parse_Statement;
      procedure Parse_Block;
      procedure Parse_VariableDeclarationList;
      procedure Parse_VariableDeclaration;
      procedure EmptyStatement;
      procedure Parse_IfStatement;
      procedure Parse_ForStatement;
      procedure Parse_DoStatement;
      procedure Parse_WhileStatement;
      procedure Parse_ContinueStatement;
      procedure Parse_BreakStatement;
      procedure Parse_ReturnStatement;
      procedure Parse_WithStatement;
      procedure Parse_SwitchStatement;
      procedure Parse_ThrowStatement;
      procedure Parse_TryStatement;
      procedure Parse_ExpressionStatement;
      procedure Parse_PrintStatement;
// Functions and Programs
      procedure Parse_FunctionDeclaration;
      procedure Parse_FunctionExpression;
      function Parse_FormalParameterList:Integer;
      procedure Parse_FunctionBody;
      function Parse_Program:boolean;
      procedure Parse_SourceElements;
      procedure Parse_SourceElement;
   end;

implementation

uses
   SysUtils,// Exception
   DXJS_MAIN,
   DXJS_OBJECT,
   DXJS_CONV;

constructor TParser.Create (aJScript:Pointer) ;
begin
   JScript:=aJScript;
   CurrLevel:=0;
   EntryStack:=TEntryStack.Create;
   StatementLabel:='';
   IsFormalParameter:=false;
   IsDeclareSwitch:=false;
   WithStack:=0;
   IncList:=TList.Create;
   DecList:=TList.Create;
end;

destructor TParser.Destroy;
begin
   EntryStack.Free;
   IncList.Free;
   DecList.Free;

   inherited;
end;

procedure TParser.AppIncList (Const K:Integer) ;
var
   I,ID:Integer;
begin
   while IncList.Count>K do begin
      I:=IncList.Count-1;
      ID:=Integer (IncList[I]) ;
      App_POSTFIX (ID) ;
      App_POSTFIX (OP_INC) ;
      App_POSTFIX (OP_POP_RET) ;
      IncList.Delete (I) ;
   end;
end;

procedure TParser.AppDecList (Const K:Integer) ;
var
   I,ID:Integer;
begin
   while DecList.Count>K do begin
      I:=DecList.Count-1;
      ID:=Integer (DecList[I]) ;
      App_POSTFIX (ID) ;
      App_POSTFIX (OP_DEC) ;
      App_POSTFIX (OP_POP_RET) ;
      DecList.Delete (I) ;
   end;
end;

procedure TParser.Call_SCANNER;
begin
   NewID:=false;
   TJScript (JScript) .Scanner.GetToken (CurrToken) ;
   if CurrToken.AClass=classSEPARATOR then begin
      App_POSTFIX (CurrToken.ID) ;
      Call_SCANNER;
      Exit;
   end
   else if CurrToken.ID=OP_EOF then begin
      Exit;
   end;
   if CurrLevel>0 then FuncDecl:=FuncDecl+CurrToken.Text+' ';
   if FieldID then begin
      CurrToken.ID:=AppConstant (CurrToken.Text) ;
      Exit;
   end;
   if IsDeclareSwitch then
      with TJScript (JScript) .SymbolTable do begin
         CurrToken.ID:=AppVariant (Undefined) ;
         SetName (CurrToken.ID,CurrToken.Text) ;
         A[CurrToken.ID].Level:=CurrLevel;
         NewID:=true;
         Exit;
      end;
   if CurrToken.ID=0 then
      if CurrToken.AClass=classID then begin
         CurrToken.ID:=TJScript (JScript) .SymbolTable.LookUpID (CurrToken.Text,CurrLevel) ;
         if not IsFormalParameter then begin
            if CurrToken.ID=0 then
               if CurrLevel>0 then
                  CurrToken.ID:=TJScript (JScript) .SymbolTable.LookUpID (CurrToken.Text,0) ;
         end;
         if CurrToken.ID=0 then
            with TJScript (JScript) .SymbolTable do begin
               CurrToken.ID:=AppVariant (Undefined) ;
               SetName (CurrToken.ID,CurrToken.Text) ;
               A[CurrToken.ID].Level:=CurrLevel;
               NewID:=true;
            end;
      end;
end;

function TParser.NextToken:TToken;
begin
   TJScript (JScript) .Scanner.GetNextToken (result) ;
end;

procedure TParser.App_POSTFIX (Const I:Integer) ;
begin
   TJScript (JScript) .Postfix.App (I) ;
end;

procedure TParser.Match (I:Integer) ; // Sept 2003
begin
   if I<>CurrToken.ID then Begin
      if I = SP_SEMICOLON then begin
        TJScript(JScript).Scanner.BuffToken := CurrToken;
        CurrToken.Text := ';';
        CurrToken.ID := SP_SEMICOLON;
      end
      Else begin
         raise TScriptFailure.Create (ParseErrors.GetCode (I)) ;
      End;
   End;
end;

function TParser.AppLabel:Integer;
begin
   result:=TJScript (JScript) .SymbolTable.AppLabel;
end;

procedure TParser.SetLabelHere (Const L:Integer) ;
begin
   with TJScript (JScript) do SymbolTable.A[L].Entry :=Postfix.Card+1 ;
end;

function TParser.AppConstant (const Value:Variant) :Integer;
begin
   result:=TJScript (JScript) .SymbolTable.AppVariantConst (Value) ;
end;

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

function TParser.Parse_Identifier:Integer;
begin
   result:=CurrToken.ID;
   if not (CurrToken.AClass in [classID,classCONST]) then
      raise TScriptFailure.Create (peIdentifierExpected) ;
   App_POSTFIX (CurrToken.ID) ;
   Call_SCANNER;
end;

procedure TParser.Parse_PrimaryExpression;
var
   S:string;
   ID,L,K:Integer;
begin
   case CurrToken.ID of
      SP_ROUND_BRACKET_L:begin// (Expression)
            Call_SCANNER;
            Parse_Expression;
            Match (SP_ROUND_BRACKET_R) ;
            Call_SCANNER;
         end;
      SP_BRACKET_L:Parse_ArrayLiteral;// (array literal)
      SP_BRACE_L:Parse_ObjectLiteral;// (object literal)
      OP_DIV:begin// (regexp literal)
            K:=1;
            App_POSTFIX (OP_CREATE_OBJECT) ;
            App_POSTFIX (TJScript (JScript) .SymbolTable.RegExpID) ;
            App_POSTFIX (OP_SAVE_CALL) ;
            L:=AppLabel;
            App_POSTFIX (L) ;
            S:=TJScript (Jscript) .Scanner.GetRegExpBody;
            App_POSTFIX (AppConstant (S) ) ;
            Call_SCANNER;
            Match (OP_DIV) ;
            if NextToken.AClass=ClassID then begin
               Inc (K) ;
               Call_SCANNER;
               App_POSTFIX (AppConstant (CurrToken.Text) ) ;
            end;
            App_POSTFIX (AppConstant (K) ) ;
            App_POSTFIX (OP_CALL) ;
            SetLabelHere (L) ;
            App_POSTFIX (OP_POP_RET) ;
            Call_SCANNER;
         end;
   else begin// Identifier
         S:=CurrToken.Text;
         if (S='arguments') and (CurrLevel>0) then begin
            with TJScript (JScript) .SymbolTable do begin
               SetName (CurrToken.ID,'') ;
               A[CurrToken.ID].Level:=0;
               ID:=AppVariantConst ('arguments') ;
            end;
            App_POSTFIX (CurrLevel) ;
            App_POSTFIX (ID) ;
            App_POSTFIX (OP_CREATE_REFERENCE) ;
            Call_SCANNER;
         end
         Else Begin
            Parse_Identifier;
            if WithStack>0 then App_POSTFIX (OP_EVAL_IDENTIFIER) ;
         End;
      end;
   end;{case}
end;

procedure TParser.Parse_ArrayLiteral;
var
   K,L,ID:Integer;
begin
// Match SP_BRACKET_L
   K:=0;
   App_POSTFIX (OP_CREATE_OBJECT) ;
   App_POSTFIX (TJScript (JScript) .SymbolTable.ArrayID) ;
   App_POSTFIX (OP_SAVE_CALL) ;
   L:=AppLabel;
   App_POSTFIX (L) ;
   Call_SCANNER;
   if CurrToken.ID<>SP_BRACKET_R then
      repeat
         if CurrToken.ID=SP_COMMA then begin
            Inc (K) ;
            App_POSTFIX (TJScript (JScript) .SymbolTable.UndefinedID) ;
            Call_SCANNER;
            if CurrToken.ID=SP_BRACKET_R then begin
               Inc (K) ;
               App_POSTFIX (TJScript (JScript) .SymbolTable.UndefinedID) ;
               Break;
            end;
         end
         else begin
            Inc (K) ;
            Parse_AssignmentExpression;
            if CurrToken.ID=SP_BRACKET_R then
               Break;
            Call_SCANNER;
         end;
      until false;
   ID:=AppConstant (K) ;
   App_POSTFIX (ID) ;
   App_POSTFIX (OP_CALL) ;
   SetLabelHere (L) ;
   App_POSTFIX (OP_POP_RET) ;
   Call_SCANNER;
end;

procedure TParser.Parse_ObjectLiteral;
var
   ID:Integer;
begin
// Match SP_BRACE_L
   App_POSTFIX (OP_CREATE_OBJECT) ;
   ID:=TJScript (JScript) .SymbolTable.AppVariant (Undefined) ;
   App_POSTFIX (ID) ;
   App_POSTFIX (OP_SWAP) ;
   App_POSTFIX (OP_ASSIGN) ;
   Call_SCANNER (true) ;
   App_POSTFIX (CurrToken.ID) ;
   App_POSTFIX (OP_CREATE_REFERENCE) ;
   Call_SCANNER;
   Match (SP_COLON) ;
   Call_SCANNER;
   Parse_AssignmentExpression;
   App_POSTFIX (OP_ASSIGN) ;
   App_POSTFIX (OP_POP_RET) ;
   while CurrToken.ID=SP_COMMA do begin
      App_POSTFIX (ID) ;
      Call_SCANNER (true) ;
      App_POSTFIX (CurrToken.ID) ;
      App_POSTFIX (OP_CREATE_REFERENCE) ;
      Call_SCANNER;
      Match (SP_COLON) ;
      Call_SCANNER;
      Parse_AssignmentExpression;
      App_POSTFIX (OP_ASSIGN) ;
      App_POSTFIX (OP_POP_RET) ;
   end;
   Match (SP_BRACE_R) ;
   App_POSTFIX (ID) ;
   Call_SCANNER;
end;

procedure TParser.Parse_MemberExpression;
var
   I,K,L:Integer;
begin
   if CurrToken.ID=WD_FUNCTION then begin
      IsDeclareSwitch:=true;
      Call_SCANNER;
      if CurrToken.AClass<>classID then
         with TJScript (JScript) .SymbolTable do begin
            CurrToken.AClass:=ClassID;
            CurrToken.Text:='';
            CurrToken.ID:=AppVariant (Undefined) ;
            A[CurrToken.ID].Level:=0;
         end;
      App_POSTFIX (CurrToken.ID) ;
      IsDeclareSwitch:=false;
      FuncDecl:='function '+CurrToken.Text;
      Parse_FunctionExpression;
   end
   else begin
      Parse_PrimaryExpression;
      while (CurrToken.ID=SP_BRACKET_L) or (CurrToken.ID=SP_POINT) or
         (CurrToken.ID=SP_ROUND_BRACKET_L) do begin
         Case CurrToken.ID of
            SP_BRACKET_L:begin
               Call_SCANNER;
               Parse_EXPRESSION;
               Match (SP_BRACKET_R) ;
               App_POSTFIX (OP_CREATE_REFERENCE) ;
               Call_SCANNER;
            end;
            SP_POINT:begin
               Call_SCANNER (true) ;
               App_POSTFIX (CurrToken.ID) ;
               App_POSTFIX (OP_CREATE_REFERENCE) ;
               Call_SCANNER;
            end;
            SP_ROUND_BRACKET_L:begin
               App_POSTFIX (OP_SAVE_CALL) ;
               L:=AppLabel;
               App_POSTFIX (L) ;
               K:=Parse_Arguments;
               I:=AppConstant (K) ;
               App_POSTFIX (I) ;
               App_POSTFIX (OP_CALL) ;
               SetLabelHere (L) ;
            end;
         end; {case}
      end;
   end;
end;

procedure TParser.Parse_NewExpression;
var
   ID:Integer;
begin