dxjs_parser.pas

Well known and usefull component for delphi 7

   SetLabelHere (L) ;
end;

procedure TParser.Parse_ForStatement;
var
   LF,L,LStatement,LIncrement,K1,K2:Integer;
begin
  // WD_FOR
   K1:=IncList.Count;
   K2:=DecList.Count;
   L:=AppLabel;
   SetLabelHere (L) ;
   LF:=AppLabel;
   LStatement:=AppLabel;
   LIncrement:=AppLabel;
   Call_SCANNER;
   Match (SP_ROUND_BRACKET_L) ;
   Call_SCANNER;
   if CurrToken.ID<>SP_SEMICOLON then begin
      if CurrToken.ID=WD_VAR then Parse_VariableDeclarationList
      else begin
         Parse_Expression;
         if CurrToken.ID<>WD_IN then App_POSTFIX (OP_POP_RET) ;
      end;
   end;
   if CurrToken.ID=WD_IN then begin
      Call_SCANNER;
      Parse_Expression;
      App_POSTFIX (TJScript (JScript) .SymbolTable.AppVariant (0) ) ;
      App_POSTFIX (OP_GET_NEXT_PROP) ;
      App_POSTFIX (LF) ;
      App_POSTFIX (OP_GO_FALSE) ;
      EntryStack.Push (LF,L,StatementLabel) ;
      Call_SCANNER;
      Parse_Statement;
      EntryStack.Pop;
      App_POSTFIX (L) ;
      App_POSTFIX (OP_GO) ;
      SetLabelHere (LF) ;
      Exit;
   end;
   Match (SP_SEMICOLON) ;
   SetLabelHere (L) ;
   Call_SCANNER;
   if CurrToken.ID<>SP_SEMICOLON then Parse_Expression
   else App_POSTFIX (TJScript (JScript) .SymbolTable.TrueID) ;
   Match (SP_SEMICOLON) ;
   App_POSTFIX (LF) ;
   App_POSTFIX (OP_GO_FALSE) ;
   App_POSTFIX (LStatement) ;
   App_POSTFIX (OP_GO) ;
   SetLabelHere (LIncrement) ;
   Call_SCANNER;
   if CurrToken.ID<>SP_ROUND_BRACKET_R then begin
      Parse_Expression;
      App_POSTFIX (OP_POP_RET) ;
   end;
   Match (SP_ROUND_BRACKET_R) ;
   App_POSTFIX (L) ;
   App_POSTFIX (OP_GO) ;
   SetLabelHere (LStatement) ;
   EntryStack.Push (LF,LIncrement,StatementLabel) ;
   Call_SCANNER;
   Parse_Statement;
   AppIncList (K1) ;
   AppDecList (K2) ;
   EntryStack.Pop;
   App_POSTFIX (LIncrement) ;
   App_POSTFIX (OP_GO) ;
   SetLabelHere (LF) ;
end;

procedure TParser.Parse_DoStatement;
var
   L,LF,K1,K2:Integer;
begin
// WD_DO
   LF:=AppLabel;
   L:=AppLabel;
   SetLabelHere (LF) ;
   Call_SCANNER;
   EntryStack.Push (L,LF,StatementLabel) ;
   Parse_Statement;
   EntryStack.Pop;
   Match (WD_WHILE) ;
   Call_SCANNER;
   K1:=IncList.Count;
   K2:=DecList.Count;
   Match (SP_ROUND_BRACKET_L) ;
   Call_SCANNER;
   Parse_Expression;
   AppIncList (K1) ;
   AppDecList (K2) ;
   Match (SP_ROUND_BRACKET_R) ;
   Call_SCANNER;
   App_POSTFIX (OP_LOGICAL_NOT) ;
   App_POSTFIX (LF) ;
   App_POSTFIX (OP_GO_FALSE) ;
   SetLabelHere (L) ;
end;

procedure TParser.Parse_WhileStatement;
var
   L,LF,K1,K2:Integer;
begin
// WD_WHILE
   LF:=AppLabel;
   L:=AppLabel;
   SetLabelHere (L) ;
   Call_SCANNER;
   Match (SP_ROUND_BRACKET_L) ;
   K1:=IncList.Count;
   K2:=DecList.Count;
   Call_SCANNER;
   Parse_Expression;
   AppIncList (K1) ;
   AppDecList (K2) ;
   Match (SP_ROUND_BRACKET_R) ;
   App_POSTFIX (LF) ;
   App_POSTFIX (OP_GO_FALSE) ;
   EntryStack.Push (LF,L,StatementLabel) ;
   Call_SCANNER;
   Parse_Statement;
   EntryStack.Pop;
   App_POSTFIX (L) ;
   App_POSTFIX (OP_GO) ;
   SetLabelHere (LF) ;
end;

procedure TParser.Parse_ContinueStatement;
begin
  // WD_CONTINUE
   if EntryStack.Card=0 then raise TScriptFailure.Create (peOutSideOfLoop) ;
   if NextToken.ID=SP_SEMICOLON then begin
      App_POSTFIX (EntryStack.TopContinueLabel) ;
      App_POSTFIX (OP_GO) ;
   end
   else begin
      Call_SCANNER;
      if not (CurrToken.AClass in [classID,classCONST]) then
         raise TScriptFailure.Create (peIdentifierExpected) ;
      App_POSTFIX (EntryStack.TopContinueLabel (CurrToken.Text) ) ;
      App_POSTFIX (OP_GO) ;
   end;
   Call_SCANNER;
end;

procedure TParser.Parse_BreakStatement;
begin
  // WD_BREAK
   if EntryStack.Card=0 then raise TScriptFailure.Create (peOutSideOfLoop) ;
   if NextToken.ID=SP_SEMICOLON then begin
      App_POSTFIX (EntryStack.TopBreakLabel) ;
      App_POSTFIX (OP_GO) ;
   end
   else begin
      Call_SCANNER;
      if not (CurrToken.AClass in [classID,classCONST]) then
         raise TScriptFailure.Create (peIdentifierExpected) ;
      App_POSTFIX (EntryStack.TopBreakLabel (CurrToken.Text) ) ;
      App_POSTFIX (OP_GO) ;
   end;
   Call_SCANNER;
end;

procedure TParser.Parse_ReturnStatement;
begin
  // WD_RETURN
   Call_SCANNER;
   if CurrToken.ID=SP_SEMICOLON then App_POSTFIX (TJScript (JScript) .SymbolTable.UndefinedID)
   else Parse_Expression;
   if CurrLevel=0 then App_POSTFIX (OP_HALT)
   else App_POSTFIX (OP_EXIT) ;
end;

procedure TParser.Parse_WithStatement;
var
   K1,K2:Integer;
begin
  // WD_WITH
   K1:=IncList.Count;
   K2:=DecList.Count;
   Call_SCANNER;
   Match (SP_ROUND_BRACKET_L) ;
   Parse_Expression;
   AppIncList (K1) ;
   AppDecList (K2) ;
   App_POSTFIX (OP_BEGIN_WITH) ;
   Inc (WithStack) ;
   Parse_Statement;
   Dec (WithStack) ;
   App_POSTFIX (OP_END_WITH) ;
end;

procedure TParser.Parse_SwitchStatement;
var
   ExprID,L,LF,K1,K2:Integer;
begin
  // WD_SWITCH
   L:=AppLabel;
   K1:=IncList.Count;
   K2:=DecList.Count;
   Call_SCANNER;
   Match (SP_ROUND_BRACKET_L) ;
   Call_SCANNER;
   Parse_Expression;
   AppIncList (K1) ;
   AppDecList (K2) ;
   Match (SP_ROUND_BRACKET_R) ;
   ExprID:=TJScript (JScript) .SymbolTable.AppVariant (Undefined) ;
   App_POSTFIX (ExprID) ;
   App_POSTFIX (OP_SWAP) ;
   App_POSTFIX (OP_ASSIGN) ;
   App_POSTFIX (OP_POP_RET) ;
   Call_SCANNER;
   Match (SP_BRACE_L) ;
   Call_SCANNER;
   if CurrToken.ID<>SP_BRACE_R then begin
      while CurrToken.ID=WD_CASE do begin
         K1:=IncList.Count;
         K2:=DecList.Count;
         Call_SCANNER;
         Parse_Expression;
         AppIncList (K1) ;
         AppDecList (K2) ;
         Match (SP_COLON) ;
         Call_SCANNER;
         LF:=AppLabel;
         App_POSTFIX (ExprID) ;
         App_POSTFIX (OP_ID) ;
         App_POSTFIX (LF) ;
         App_POSTFIX (OP_GO_FALSE) ;
         EntryStack.Push (L,0,StatementLabel) ;
         repeat
            Parse_Statement;
            Case CurrToken.ID of
               SP_BRACE_R,WD_CASE,WD_DEFAULT:Break;
            end;
         until false;
         EntryStack.Pop;
         SetLabelHere (LF) ;
      end;
      if CurrToken.ID=WD_DEFAULT then begin
         Call_SCANNER;
         Match (SP_COLON) ;
         Call_SCANNER;
         EntryStack.Push (L,0,StatementLabel) ;
         repeat
            Parse_Statement;
            if CurrToken.ID=SP_BRACE_R then Break;
         until false;
         EntryStack.Pop;
      end;
   end;
   Match (SP_BRACE_R) ;
   SetLabelHere (L) ;
   Call_SCANNER;
end;

procedure TParser.Parse_ThrowStatement;
var
   K1,K2:Integer;
begin
  // WD_THROW
   K1:=IncList.Count;
   K2:=DecList.Count;
   Call_SCANNER;
   Parse_Expression;
   AppIncList (K1) ;
   AppDecList (K2) ;
   App_POSTFIX (OP_THROW) ;
   Call_SCANNER;
end;

procedure TParser.Parse_TryStatement;
var
   L,LTRY:Integer;
begin
  // WD_TRY
   LTRY:=AppLabel;
   App_POSTFIX (LTRY) ;
   App_POSTFIX (OP_TRY_ON) ;
   Call_SCANNER;
   Parse_Block;
   L:=AppLabel;
   App_POSTFIX (L) ;
   App_POSTFIX (OP_GO) ;
   if (CurrToken.ID<>WD_CATCH) and (CurrToken.ID<>WD_FINALLY) then
      Match (WD_CATCH) ;
   while CurrToken.ID=WD_CATCH do begin
      App_POSTFIX (OP_CATCH) ;
      Call_SCANNER;
      Match (SP_ROUND_BRACKET_L) ;
      Call_SCANNER;
      Parse_Identifier;
      Match (SP_ROUND_BRACKET_R) ;
      App_POSTFIX (OP_SWAP) ;
      App_POSTFIX (OP_ASSIGN) ;
      App_POSTFIX (OP_POP_RET) ;
      Call_SCANNER;
      Parse_Block;
      App_POSTFIX (OP_CLEAR_ERROR) ;
      App_POSTFIX (L) ;
      App_POSTFIX (OP_GO) ;
   end;
   SetLabelHere (L) ;
   if Currtoken.ID=WD_FINALLY then begin
      App_POSTFIX (OP_FINALLY) ;
      Call_SCANNER;
      Parse_Block;
      App_POSTFIX (OP_COND_EXIT) ;
   end;
   SetLabelHere (LTRY) ;
   App_POSTFIX (OP_TRY_OFF) ;
end;

procedure TParser.Parse_ExpressionStatement;
begin
  // id
   Parse_Expression;
end;

procedure TParser.Parse_PrintStatement;
begin
  // Match(WD_PRINT);
   repeat
      Call_SCANNER;
      Parse_AssignmentExpression;
      App_POSTFIX (OP_PRINT) ;
   until CurrToken.ID<>SP_COMMA;
end;

/////////////////////////////////
//// FUNCTIONS AND PROGRAMS /////
/////////////////////////////////

procedure TParser.Parse_FunctionDeclaration;
var
   L,ParamCount:Integer;
   SO:TScriptObject;
begin
   with TJScript (JScript) do begin
      SymbolTable.SetName (CurrToken.ID,CurrToken.Text) ;
      SymbolTable.A[CurrToken.ID].Kind:=Kind_is_SUB;
      SymbolTable.AppThisID (CurrToken.ID) ;
   end;
   L:=AppLabel;
   App_POSTFIX (L) ;
   App_POSTFIX (OP_GO) ;
   CurrLevel:=CurrToken.ID;
   ParamCount:=0;
   if CurrToken.Text<>'' then begin
      Parse_Identifier;
      Match (SP_ROUND_BRACKET_L) ;
   end;
   SetLabelHere (CurrLevel) ;
   IsFormalParameter:=true;
   Call_SCANNER;
   if CurrToken.ID<>SP_ROUND_BRACKET_R then ParamCount:=Parse_FormalParameterList;
   with TJScript (JScript) do
      SymbolTable.A[CurrLevel].Count:=ParamCount ;
   IsFormalParameter:=false;
   Match (SP_ROUND_BRACKET_R) ;
   Call_SCANNER;
   Match (SP_BRACE_L) ;
   Call_SCANNER;
   Parse_FunctionBody;
   Match (SP_BRACE_R) ;
   App_POSTFIX (TJScript (JScript) .SymbolTable.UndefinedID) ;
   App_POSTFIX (OP_EXIT) ;
   App_POSTFIX (OP_RET) ;
   with TJScript (JScript) do begin
      SymbolTable.SetEndOfSub (CurrLevel) ;
      SO:=TFunctionObject.Create (FuncDecl,CurrLevel,nil,SymbolTable.A[CurrLevel].Count,JScript) ;
      SymbolTable.PutVariant (CurrLevel,ScriptObjectToVariant (SO) ) ;
   end;
   SetLabelHere (L) ;
   CurrLevel:=0;
   Call_SCANNER;
end;

procedure TParser.Parse_FunctionExpression;
begin
   Parse_FunctionDeclaration;
end;

function TParser.Parse_FormalParameterList:Integer;
begin
   result:=1;
   Parse_Identifier;
   App_POSTFIX (OP_PASS_BY_VAL) ;
   while CurrToken.ID=SP_COMMA do begin
      Inc (result) ;
      Call_SCANNER;
      if not NewID then raise TScriptFailure.Create (peIdentifierRedeclared) ;
      Parse_Identifier;
      App_POSTFIX (OP_PASS_BY_VAL) ;
   end;
end;

procedure TParser.Parse_FunctionBody;
begin
   Parse_SourceElements;
end;

function TParser.Parse_Program:boolean;
begin
   result:=true;
   try
      Parse_SourceElements;
   except
      on E:TScriptFailure do begin
         E.Message:=ParseErrors[E.Code];
         TJScript (JScript) .CreateErrorObject (E) ;
         result:=false;
         TJScript (JScript) .Print;
      end;
      on E:Exception do begin
         TJScript (JScript) .CreateErrorObject (E) ;
         result:=false;
         TJScript (JScript) .Print;
      end;
   end;
end;

procedure TParser.Parse_SourceElements;
begin
   repeat
      if CurrToken.ID=SP_BRACE_R then Exit;
      Parse_SourceElement;
      Case CurrToken.ID of
         OP_EOF,SP_POINT:Exit;
      End;
   until false;
end;

procedure TParser.Parse_SourceElement;
begin
   Case CurrToken.ID of
      WD_FUNCTION:begin
         IsDeclareSwitch:=true;
         Call_SCANNER;
         IsDeclareSwitch:=false;
         FuncDecl:='function '+CurrToken.Text;
         Parse_FunctionDeclaration;
      end;
      SP_POINT:Exit;
      else Parse_Statement;
   End;
end;

end.