pax_javascript.pas

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

  else if IsCurrText('goto') then
  begin
    IsExecutable := true;
    Parse_GoToStmt;
    IsExecutable := false;
    Match(';');
    Call_SCANNER;
  end
  else if IsCurrText('if') then
  begin
    IsExecutable := true;
    Parse_IfStmt;
    IsExecutable := false;
  end
  else if IsCurrText('throw') then
  begin
    IsExecutable := true;
    Parse_ThrowStmt;
    IsExecutable := false;
  end
  else if IsCurrText('try') then
  begin
    IsExecutable := true;
    Parse_TryStmt;
    IsExecutable := false;
  end
  else if IsCurrText('var') then
  begin
    Parse_VarStmt(false, ml);
    Match(';');
    Call_SCANNER;
  end
  else if IsCurrText('return') then
  begin
    IsExecutable := true;
    Parse_ReturnStmt;
    IsExecutable := false;
    Match(';');
    Call_SCANNER;
  end
  else if IsCurrText('do') then
  begin
    IsExecutable := true;
    Parse_DoStmt;
    IsExecutable := false;
  end
  else if IsCurrText('for') then
  begin
    IsExecutable := true;
    Parse_ForStmt;
    IsExecutable := false;
  end
  else if IsCurrText('while') then
  begin
    IsExecutable := true;
    Parse_WhileStmt;
    IsExecutable := false;
  end
  else if IsCurrText('continue') then
  begin
    IsExecutable := true;
    Parse_ContinueStmt;
    IsExecutable := false;
  end
  else if IsCurrText('break') then
  begin
    IsExecutable := true;
    Parse_BreakStmt;
    IsExecutable := false;
  end
  else if IsCurrText('switch') then
  begin
    IsExecutable := true;
    Parse_SwitchStmt;
    IsExecutable := false;
  end
  else if IsCurrText('with') then
  begin
    IsExecutable := true;
    Parse_WithStmt;
    IsExecutable := false;
  end
  else if IsCurrText('using') then
    Parse_ImportsStmt
  else if IsCurrText('print') then
  begin
    IsExecutable := true;
    Parse_PrintList;
    IsExecutable := false;
    Match(';');
    Call_SCANNER;
  end
  else if IsCurrText('println') then
  begin
    IsExecutable := true;
    Parse_PrintlnList;
    IsExecutable := false;
    Match(';');
    Call_SCANNER;
  end
  else
  begin
    IsExecutable := true;
    Parse_ExpressionStmt;
    IsExecutable := false;

    if Code.Prog[Code.Card].Op = OP_SAVE_RESULT then
      if Code.Prog[Code.Card - 1].Op = OP_CALL then
      begin
        Dec(Code.Card);
        SymbolTable.Level[Code.Prog[Code.Card].Res] := 0;
        Code.Prog[Code.Card].Res := 0;
      end;

    Match(';');
    Call_SCANNER;
  end;

  GenDestroyArrayArgumentList;
end;

procedure TPaxJavaScriptParser.Parse_Block;
begin
// Match "{"

  Call_SCANNER;
  if not IsCurrText('}') then
  repeat
     Parse_Statement;
     if IsCurrText('}') then
       Break;
  until false;
  IsExecutable := true;
  Gen(OP_SKIP, 0, 0, 0);
  IsExecutable := false;
  Match('}');
end;

procedure TPaxJavaScriptParser.Parse_NamespaceStmt(ml: TPAXModifierList);
var
  NamespaceID: Integer;
begin
  // match "namespace"
  CurrClassRec.UsingInitList.Add(LastCodeLine);

  Call_SCANNER;
  NamespaceID := Parse_Ident;

  Kind[NamespaceID] := KindTYPE;

  LevelStack.PushClass(NamespaceID, 0, ml + [modSTATIC], ckClass, false);

  Match('{');
  Gen(OP_USE_NAMESPACE, UsingList.Push(NamespaceID), 0, 0);
  Gen(OP_HALT_OR_NOP, 0, 0, 0);

  Parse_Block;
  Gen(OP_END_OF_NAMESPACE, 0, 0, 0);

  Call_SCANNER;

  LevelStack.Pop;
  UsingList.Pop;
end;

procedure TPaxJavaScriptParser.Parse_IfStmt;
var
  ExprID, L, LF: Integer;
begin
  // match "if"
  LF := NewLabel;

  Call_SCANNER;
  Match('(');

  Call_SCANNER;
  ExprID := Parse_Expression;
  GenDestroyArrayArgumentList;

  Gen(OP_GO_FALSE, LF, ExprID, 0);

  Match(')');

  Call_SCANNER;
  Parse_Statement;

  if IsCurrText('else') then
  begin
    L := NewLabel;
    Gen(OP_GO, L, 0, 0);

    SetLabelHere(LF);
    Call_SCANNER;
    Parse_Statement;

    SetLabelHere(L);
  end
  else
    SetLabelHere(LF);
end;

procedure TPaxJavaScriptParser.Parse_DoStmt;
var
  L, LF, ExprID, ID: Integer;
begin
// match "do"

  LF := NewLabel;
  L := NewLabel;

  SetLabelHere(LF);

  Call_SCANNER;

  EntryStack.Push(L, LF, StatementLabel);

  Parse_Statement;

  EntryStack.Pop;

  Match('while');

  Call_SCANNER;

  Match('(');
  Call_SCANNER;
  ExprID := Parse_Expression;
  Match(')');

  Call_SCANNER;

  ID := NewVar;
  Gen(OP_NOT, ExprID, 0, ID);
  Gen(OP_GO_FALSE, LF, ID, 0);

  SetLabelHere(L);
end;

procedure TPaxJavaScriptParser.Parse_ForStmt;
var
  LF, L, LStatement, LIncrement, TempClass,
  LoopCounterID, ResID: Integer;
begin
  // match "for"

  TempClass := 0;

  LevelStack.Save;

  L := NewLabel;
  SetLabelHere(L);

  LF := NewLabel;
  LStatement := NewLabel;
  LIncrement := NewLabel;

  Call_SCANNER;
  Match('(');

  Call_SCANNER;
  LoopCounterID := 0;
  if not IsCurrText(';') then
  begin
    if IsCurrText('var') then
    begin
      if CurrSubID = 0 then
        TempClass := LevelStack.PushTempClass;
      LoopCounterID := Parse_VarStmt(false, []);
      if CurrSubID = 0 then
        Gen(OP_BEGIN_WITH, TempClass, 0, 0);
    end
    else
    begin
      if IsNextText('in') then
        LoopCounterID := Parse_Ident
      else
        LoopCounterID := Parse_Expression;
    end;
  end;

  if IsCurrText('in') then
  begin
    Gen(OP_OPTIMIZATION_OFF, 0, 0, 0);

    ResID := NewVar(0);
    Call_SCANNER;
    SetLabelHere(LIncrement);
    Gen(OP_GET_NEXT_PROP, LoopCounterID, Parse_Expression, ResID);
    Gen(OP_GO_FALSE, LF, ResID, 0);
    Call_SCANNER;
    Parse_Statement;
    Gen(OP_GO, LIncrement, 0, 0);
    SetLabelHere(LF);
    LevelStack.Restore;
    if TempClass > 0 then
      Gen(OP_END_WITH, 0, 0, 0);

    Gen(OP_OPTIMIZATION_ON, 0, 0, 0);
    Exit;
  end;

  Match(';');
  SetLabelHere(L);

  Call_SCANNER;
  if not IsCurrText(';') then
    Gen(OP_GO_FALSE, LF, Parse_Expression, 0)
  else
    Gen(OP_GO_FALSE, LF, NewConst(true), 0);

  Match(';');

  Gen(OP_GO, LStatement, 0, 0);

  SetLabelHere(LIncrement);

  Call_SCANNER;
  if not IsCurrText(')') then
    Parse_Expression;

  Match(')');

  Gen(OP_GO, L, 0, 0);

  SetLabelHere(LStatement);

  EntryStack.Push(LF, LIncrement, StatementLabel);

  Call_SCANNER;
  Parse_Statement;

  EntryStack.Pop;

  Gen(OP_GO, LIncrement, 0, 0);

  SetLabelHere(LF);

  LevelStack.Restore;

  if TempClass > 0 then
    Gen(OP_END_WITH, 0, 0, 0);
end;

procedure TPaxJavaScriptParser.Parse_WhileStmt;
var
  L, LF, ExprID: Integer;
begin
// match "while"

  L := NewLabel;
  LF := NewLabel;

  SetLabelHere(L);

  Call_SCANNER;
  Match('(');

  Call_SCANNER;
  ExprID := Parse_Expression;

  Match(')');

  Gen(OP_GO_FALSE, LF, ExprID, 0);

  EntryStack.Push(LF, L, StatementLabel);

  Call_SCANNER;
  Parse_Statement;

  EntryStack.Pop;

  Gen(OP_GO, L, 0, 0);

  SetLabelHere(LF);
end;

procedure TPAXJavaScriptParser.Parse_ContinueStmt;
begin
  // match "continue"

  Call_SCANNER;

  if IsCurrText(';') then
    Gen(OP_EXIT, EntryStack.TopContinueLabel, 0, 0)
  else
  begin
    if not (CurrToken.TokenClass = tcId) then
      raise TPAXScriptFailure.Create(errIdentifierExpected);
    Gen(OP_EXIT, EntryStack.TopContinueLabel(CurrToken.Text), 0, 0);
    Call_SCANNER;
  end;

  Match(';');
  Call_SCANNER;
end;

procedure TPAXJavaScriptParser.Parse_BreakStmt;
begin
  // match "break"

  if EntryStack.Count = 0 then
    raise TPAXScriptFailure.Create(errStatementIsNotAllowedHere);

  Call_SCANNER;

  if IsCurrText(';') then
    Gen(OP_EXIT, EntryStack.TopBreakLabel, 0, 0)
  else
  begin
    if not (CurrToken.TokenClass = tcId) then
      raise TPAXScriptFailure.Create(errIdentifierExpected);
    Gen(OP_EXIT, EntryStack.TopBreakLabel(CurrToken.Text), 0, 0);
    Call_SCANNER;
  end;

  Match(';');
  Call_SCANNER;
end;

function TPaxJavaScriptParser.Parse_FunctionStmt(ml: TPAXModifierList): Integer;

var
  ParamCount, ArgumentsID, SubID: Integer;

procedure CreateArguments;
const
  MaxArg = 10;
var
  ID_REF,
  L_BREAK,
  L_CONTINUE,
  ID_I, ID_COUNT, ID_COMPARE, ID_VAL: Integer;
begin
  L_BREAK := NewLabel;
  L_CONTINUE := NewLabel;
  ID_I := NewVar;
  ID_COUNT := NewVar;
  ID_COMPARE := NewVar;
  ID_VAL := NewVar;
  Gen(OP_GET_PARAM_COUNT, ID_COUNT, 0, 0);

{  34   Line     5    arguments = new Array();               :20025
   38   CREATE OBJEC     Array[ 2493]                             $$20041
   39     CREATE REF          $$20041                 2      Array[20042]
   40           CALL     Array[20042]                 0           $$20043
   41             := arguments[20040]           $$20043  arguments[20040]
}
  ID_REF := NewVar;
  Name[ID_REF] := 'Array';
  Gen(OP_CREATE_OBJECT, ClassList.FindClassByName('Array').ClassID, 0, ArgumentsID);
  GenRef(ArgumentsID, maAny, ID_REF);
  Gen(OP_CALL, ID_REF, 0, ArgumentsID);

{  41   Line     6    Count = 2;                             :20027
   45             :=     Count[20044]                 2      Count[20044]
   47   Line     7    I = 0;                                 :20027
   51             :=         I[20045]                 0          I[20045]
   53   Line     8    while (I < Count) {                    :20027
   57          <(ex)         I[20045]      Count[20044]           $$20048
   58       GO_FALSE              81^           $$20048
   59   Line     9      arguments[I] = _1;                   :20027
   64           PUSH         I[20045]
   68           PUSH        _1[20030]
   69   PUT PROPERTY arguments[20040]                 2
   71   Line    10      I = I + 1;                           :20027
   76          +(ex)         I[20045]                 1           $$20050
   77             :=         I[20045]           $$20050          I[20045]
   80             GO              53^ }

  Gen(OP_ASSIGN, ID_I, NewConst(0), ID_I);

  SetLabelHere(L_CONTINUE);

  Gen(OP_LT, ID_I, ID_COUNT, ID_COMPARE);
  Gen(OP_GO_FALSE, L_BREAK, ID_COMPARE, 0);
  Gen(OP_GET_PARAM, SubID, ID_I, ID_VAL);
  Gen(OP_PUSH, ID_I, 0, 0);
  Gen(OP_PUSH, ID_VAL, 0, 0);
  Gen(OP_PUT_PROPERTY, ArgumentsID, 2, 0);
  Gen(OP_PLUS, ID_I, NewConst(1), ID_I);
  Gen(OP_GO, L_CONTINUE, 0, 0);

  SetLabelHere(L_BREAK);
end;

function FindLeftSideClassID: Integer;
var
  I, J: Integer;
begin
  result := 0;
  for I:=Code.Card downto 1 do
    if (Code.Prog[I].Op = OP_CREATE_REF) and (Code.Prog[I].Res = LeftSideID) then
    begin
      J := I;
      while Code.Prog[J].Op = OP_CREATE_REF do
        Dec(J);
      Inc(J);
      if Kind[Code.Prog[J].Arg1] = KindTYPE then
      begin
        result := Code.Prog[J].Arg1;
        Exit;
      end
      else
        break;
    end;
  if Kind[LevelStack.Top] = KindSUB then
  begin
    result := LevelStack.Top;
    while Kind[result] <> KindTYPE do
      Dec(result);
  end;
end;

var
  L, I, ID1, ID2, ClassID, AncestorClassID, ResID, PrototypeID, TempCard,
  ParamID, ValID: Integer;
  LeftSideClassID: Integer;
const
  MaxArg = 10;
begin
  // match "function"
  LeftSideClassID := 0;

  Gen(OP_SKIP, 0, 0, 0);
  L := NewLabel;
  Gen(OP_GO, L, 0, 0);

  DeclareSwitch := true;
  Call_SCANNER;

  if IsCurrText('(') then
  begin
    ClassID := NewVar;
    Name[ClassID] := Name[LeftSideID];
    LeftSideClassID := FindLeftSideClassID;
  end
  else
    ClassID := Parse_Ident;
  Kind[ClassID] := KindTYPE;

  AncestorClassID := NewVar;
  Name[AncestorClassID] := 'Function';

  if LeftSideClassID > 0 then
    LevelStack.Push(LeftSideClassID)
  else
    LevelStack.PushClass(ClassID, AncestorClassID, [], ckCLASS, false);

  PrototypeID := NewVar;
  Name[PrototypeID] := 'prototype';
  CurrClassRec.AddField(PrototypeID, [modSTATIC]);

  SubID := NewVar;

  if LeftSideClassID > 0 then