base_parser.pas

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

    for I:=1 to Length(CurrToken.Text) do
      case CurrToken.Text[I] of
        'g','G':
        begin
          ID := NewVar;
          Name[ID] := 'global';
          GenRef(result, MaAny, ID);
          Gen(OP_PUSH, NewConst('true'), 0, 0);
          Gen(OP_PUT_PROPERTY, ID, 1, 0);
        end;
        'i','I':
        begin
          ID := NewVar;
          Name[ID] := 'ignoreCase';
          GenRef(result, MaAny, ID);
          Gen(OP_PUSH, NewConst('true'), 0, 0);
          Gen(OP_PUT_PROPERTY, ID, 1, 0);
        end;
        'm','M':
        begin
          ID := NewVar;
          Name[ID] := 'multiline';
          GenRef(result, MaAny, ID);
          Gen(OP_PUSH, NewConst('true'), 0, 0);
          Gen(OP_PUT_PROPERTY, ID, 1, 0);
        end;
      end;
  end;

  Call_SCANNER;
end;

procedure TPAXParser.Parse_PrintList;
begin
  // print
  Call_SCANNER;

  repeat
    Gen(OP_PRINT, Parse_ArgumentExpression, 0, 0);
    if IsCurrText(',') then
      Call_SCANNER
    else
      Break;
  until false;
end;

procedure TPAXParser.Parse_PrintlnList;
begin
  // print
  Call_SCANNER;

  repeat
    Gen(OP_PRINT, Parse_ArgumentExpression, 0, 0);
    if IsCurrText(',') then
      Call_SCANNER
    else
      Break;
  until false;
  Gen(OP_PRINT, NewConst('\r\n'), 0, 0);
end;

function TPAXParser.BinOp(OP, Arg1, Arg2: Integer): Integer;
begin
  result := NewVar;
  Gen(OP, Arg1, Arg2, result);
end;

function TPAXParser.IsOperator(OperList: TPAXIds; var OP: Integer): Boolean;
var
  I: Integer;
begin
  if CurrToken.TokenClass <> tcSpecial then
  begin
    result := false;
    Exit;
  end;

  I := OperList.IndexOf(CurrToken.ID);
  if I >= 0 then
  begin
    result := true;
    OP := OperList[I];
    Call_SCANNER;
  end
  else
    result := false;
end;

function TPAXParser.Parse_StringLiteral: Integer;
var
  K, ID, Count, FormatID, ArrayID, SubID: Integer;
  S: String;
begin
  Count := Scanner.VarNameList.Count;
  if Count = 0 then
    result := CurrToken.ID
  else
  begin
    FormatID := LookupID('Format');
    ArrayID := NewVar;
    Result := NewVar;

    Gen(OP_PUSH, NewConst(Count - 1), 0, 0);
    Gen(OP_CREATE_ARRAY, ArrayID, 1, 0);

    for K:=0 to Count - 1 do
    begin
      Gen(OP_PUSH, NewConst(K), 0, 0);

      S := Scanner.VarNameList[K];
      ID := NewVar;
      Name[ID] := S;
      Gen(OP_EVAL_WITH, 0, 0, ID);
      Gen(OP_PUSH, ID, 0, 0);

      Gen(OP_PUT_PROPERTY, ArrayID, 2, 0);
    end;

    Gen(OP_PUSH, CurrToken.ID, 0, 0);
    Gen(OP_PUSH, ArrayID, 0, 0);
    Gen(OP_CALL, FormatID, 2, Result);
    Gen(OP_DESTROY_OBJECT, ArrayID, 0, 0);
  end;

  Scanner.VarNameList.Clear;

  Call_SCANNER;
  if IsCurrText('with') then
  begin
    Call_SCANNER;
    Gen(OP_PUSH, result, 0, 0);
    Gen(OP_PUSH, Parse_ArrayLiteral, 0, 0);
    SubID := LookUpID('Format');
    result := NewVar;
    Gen(OP_CALL, SubID, 2, result);
  end;
end;

procedure TPAXParser.GenHtml;
var
  K, ID, Count, FormatID, ArrayID, ResultID, N: Integer;
  S: String;
begin
  CurrToken.ID := SymbolTable.CodeStringConst(CurrToken.Text);

  N := Code.Card + 1;

  Count := Scanner.VarNameList.Count;
  if Count = 0 then
    Gen(OP_PRINT_HTML, CurrToken.ID, 0, N)
  else
  begin
    FormatID := LookupID('Format');
    ArrayID := NewVar;
    ResultID := NewVar;

    Gen(OP_PUSH, NewConst(Count - 1), 0, 0);
    Gen(OP_CREATE_ARRAY, ArrayID, 1, 0);

    for K:=0 to Count - 1 do
    begin
      Gen(OP_PUSH, NewConst(K), 0, 0);

      S := Scanner.VarNameList[K];
      ID := NewVar;
      Name[ID] := S;
      Gen(OP_EVAL_WITH, 0, 0, ID);
      Gen(OP_PUSH, ID, 0, 0);

      Gen(OP_PUT_PROPERTY, ArrayID, 2, 0);
    end;

    Gen(OP_PUSH, CurrToken.ID, 0, 0);
    Gen(OP_PUSH, ArrayID, 0, 0);
    Gen(OP_CALL, FormatID, 2, ResultID);
    Gen(OP_DESTROY_OBJECT, ArrayID, 0, 0);
    Gen(OP_PRINT_HTML, ResultID, 0, N);
  end;

  Scanner.VarNameList.Clear;
end;

function TPAXParser.Parse_ArrayLiteral: Integer;
var
  L, K, ArgID: Integer;

procedure Parse_Element;
var
  S: String;
  c, c1, c2: Char;
  I, I1, I2: Integer;
begin
  if IsNextText('..') then
  begin
    S := CurrToken.Text;
    if CurrToken.TokenClass = tcIntegerConst then
    begin
      I1 := StrToInt(S);
      Call_SCANNER;
      Call_SCANNER;
      S := CurrToken.Text;
      I2 := StrToInt(S);
      Call_SCANNER;
      for I := I1 to I2 do
      begin
        ArgID := NewConst(I);

        Inc(K);
        Gen(OP_PUSH, NewConst(K), 0, 0);
        Gen(OP_PUSH, ArgID, 0, 0);
        Gen(OP_PUT_PROPERTY, result, 2, 0);
      end;
    end
    else if CurrToken.TokenClass = tcStringConst then
    begin
      c1 := S[1];
      Call_SCANNER;
      Call_SCANNER;
      S := CurrToken.Text;
      Call_SCANNER;
      c2 := S[1];
      for c := c1 to c2 do
      begin
        S := c;
        ArgID := NewConst(S);

        Inc(K);
        Gen(OP_PUSH, NewConst(K), 0, 0);
        Gen(OP_PUSH, ArgID, 0, 0);
        Gen(OP_PUT_PROPERTY, result, 2, 0);
      end;
    end
    else
      raise TPaxScriptFailure.Create(errConstantExpected);
  end
  else
  begin
    Inc(K);
    Gen(OP_PUSH, NewConst(K), 0, 0);
    ArgID := Parse_ArgumentExpression;
    Gen(OP_PUSH, ArgID, 0, 0);
    Gen(OP_PUT_PROPERTY, result, 2, 0);
  end;
end;

begin
  Match('[');
  Call_SCANNER;

  K := -1;
  result := NewVar;

  if ArgumentListSwitch then
    ArrayArgumentList.Add(result);

//  TempObjectList.Add(result);
  Gen(OP_PUSH, 0, 0, 0);
  L := LastCodeLine;

  Gen(OP_CREATE_ARRAY, result, 1, 0);

  if not IsCurrText(']') then
  begin
    Parse_Element;
    while IsCurrText(',') do
    begin
      Call_SCANNER;
      Parse_Element;
    end;
  end
  else
    K := -1;

  with Code do
    Prog[L].Arg1 := NewConst(K);

  Match(']');
  Call_SCANNER;
end;

procedure TPAXParser.Parse_ObjectInitializer(ObjectID: Integer);
var
  FieldID, K: Integer;
begin
  K := -1;
  // match "("
  Call_SCANNER;
  if IsCurrText(')') then
    Call_SCANNER
  else
  repeat
    FieldID := NewVar;
    Inc(K);
    Gen(OP_GET_FIELD, ObjectID, K, FieldID);
    if IsCurrText('(') then
    begin
      Parse_ObjectInitializer(FieldID);
    end
    else
    begin
      Gen(OP_ASSIGN, FieldID, Parse_ArgumentExpression(), FieldID);
    end;
    if IsCurrText(',') then
      Call_SCANNER
    else
      break;
  until false;
  Match(')');
  Call_SCANNER;
end;

function TPAXParser.Parse_CallConv: Integer;
var
  S: String;
  Temp: Integer;
begin
  S := NextToken.Text;

  result := -1;
  if StrEql(S, 'register') then
    result := _ccRegister
  else if StrEql(S, 'stdcall') then
    result := _ccStdCall
  else if StrEql(S, 'safecall') then
    result := _ccSafeCall
  else if StrEql(S, 'cdecl') then
    result := _ccCDecl
  else if StrEql(S, 'pascal') then
    result := _ccPascal;

  if result >= 0 then
  begin
    Temp := SymbolTable.Card;
    Call_SCANNER; // call conv
    Call_SCANNER;
    SymbolTable.Card := Temp;
  end;
end;

procedure TPAXParser.Parse_ReducedAssignment(LeftID: Integer);
var
  Card1, Card2, NP, RightID, TempVar, I: Integer;
  SaveProg: TPAXCodeRec;
  IsCall: Boolean;
begin
  Card1 := Code.Card;
  RightID := Parse_EvalExpression;
  Card2 := Code.Card;

  IsCall := IsCallOperator;

  if Code.Prog[Card2].OP = OP_SEPARATOR then
  with Code do
  begin
    SaveProg := Prog[Card];

    Dec(Card);
    Dec(Card2);
  end
  else
    SaveProg.Op := OP_NOP;

  NP := Code.Prog[Card2].Arg2;

  TempVar := 0;
  if IsCall then
  begin
    TempVar := NewVar;
    Gen(OP_ASSIGN, TempVar, Code.Prog[Card2].Res, TempVar);
  end;

  with Code do
  if IsCall then
  for I:=Card1 to Card2 - 1 do
  begin
    Inc(Card);

    if Prog[I].Op = OP_SEPARATOR then
    begin
      SaveProg := Prog[I];

      Prog[Card].Op := OP_NOP;
      Prog[Card].Arg1 := 0;
      Prog[Card].Arg2 := 0;
      Prog[Card].Res := 0;
    end
    else
    begin
      Prog[Card].Op := Prog[I].Op;
      Prog[Card].Arg1 := Prog[I].Arg1;
      Prog[Card].Arg2 := Prog[I].Arg2;
      Prog[Card].Res := Prog[I].Res;
    end;
  end;

  if IsCall then
  begin
    Gen(OP_PUSH, SymbolTable.IDundefined, 0, 0);
    Gen(OP_PUT_PROPERTY, LeftID, NP + 1, 0);
    Gen(OP_DESTROY_OBJECT, LeftID, 0, 0);
    Gen(OP_ASSIGN, LeftID, TempVar, LeftID);
//    Gen(OP_ASSIGN, TempVar, SymbolTable.IDundefined, TempVar);
  end
  else
  begin
    Gen(OP_DESTROY_OBJECT, LeftID, 0, 0);
    Gen(OP_ASSIGN, LeftID, RightID, LeftID);
  end;

  if SaveProg.Op <> OP_NOP then
  with Code do
  begin
    Inc(Card);
    Prog[Card].Op := SaveProg.Op;
    Prog[Card].Arg1 := SaveProg.Arg1;
    Prog[Card].Arg2 := SaveProg.Arg2;
    Prog[Card].Res := SaveProg.Res;
  end;
end;

procedure TPaxParser.MoveUpSourceLine;
var
  I: Integer;
begin
  with Code do
  begin
    I := Card;
    while Prog[I].Op <> OP_SEPARATOR do
      Dec(I);

    Inc(Card);
    Prog[Card] := Prog[I];
    Prog[I].Op := OP_NOP;
  end;
end;

function TPaxParser.Parse_ShortEvalAND(ID: Integer;
                                       Method0: TIntegerMethodNoParam;
                                       Method1: TIntegerMethodOneParam): Integer;
var
  LF: Integer;
begin
  if Assigned(Method0) and Assigned (Method1) then
    raise Exception.Create(errInternalError);
  if (not Assigned(Method0)) and (not Assigned (Method1)) then
    raise Exception.Create(errInternalError);

  LF := NewLabel;
  result := NewVar;
  Gen(OP_ASSIGN, result, ID, result);
  Gen(OP_GO_FALSE, LF, result, 0);
  if Assigned(Method0) then
    Gen(OP_ASSIGN, result, Method0(), result)
  else
    Gen(OP_ASSIGN, result, Method1(0), result);
  SetLabelHere(LF);
end;


function TPaxParser.Parse_ShortEvalOR(ID: Integer;
                                      Method0: TIntegerMethodNoParam;
                                      Method1: TIntegerMethodOneParam): Integer;
var
  LT: Integer;
begin
  if Assigned(Method0) and Assigned (Method1) then
    raise Exception.Create(errInternalError);
  if (not Assigned(Method0)) and (not Assigned (Method1)) then
    raise Exception.Create(errInternalError);

  LT := NewLabel;
  result := NewVar;
  Gen(OP_ASSIGN, result, ID, result);
  Gen(OP_GO_TRUE, LT, result, 0);
  if Assigned(Method0) then
    Gen(OP_ASSIGN, result, Method0(), result)
  else
    Gen(OP_ASSIGN, result, Method1(0), result);
  SetLabelHere(LT);
end;

function TPaxParser.IsBaseType(const S: String): Boolean;
var
  I: Integer;
begin
  result := false;
  for I:=0 to PaxTypes.Count - 1 do
    if StrEql(PaxTypes[I], S) then
    begin
      result := true;
      Exit;
    end;
end;

function TPaxParser.UndefinedID: Integer;
begin
  result := SymbolTable.IDundefined;
end;

procedure TPaxParser.TestDupLocalVars(NewVarID: Integer);
var
  S: String;
  I, tempID, L, tempL: Integer;
  b: Boolean;
begin
  S := Name[NewVarID];
  L := SymbolTable.Level[NewVarID];
  for I:=0 to LocalVars.Count - 1 do
  begin
    tempID := LocalVars[I];
    if UpCase then
      b := StrEql(Name[tempID], S)
    else
      b := Name[tempID] = S;
    if b then
    begin
      TempL := SymbolTable.Level[tempID];
      if tempL = L then
        raise TPAXScriptFailure.Create(Format(errIdentifierIsRedeclared, [Name[tempID]]));
    end;
  end;
end;

end.