cs2.pas

Delphi script parser

          end; {CSTI_Integer}
        CSTI_Real:
          begin
            if (Res^.VType >= CSV_Real) and (Res^.VType <= CSV_Comp) then
              Work^.CajVariant := CreateCajVariant(res^.VType, 0)
            else
              Work^.CajVariant := CreateCajVariant(CSV_Extended, 0);
            Work^.TType := 0;
            SetReal(Work^.CajVariant, StrToReal(GetToken(Parser)));
            if not DoPreCalc then
            begin
              DestroyCajVariant(Work^.CajVariant);
              Dispose(Work);
              DisposeList;
              Exit;
            end;
            NextNoJunk(Parser);
            Items.Add(Work);
          end; {CSTI_Real}
        CSTI_String, CSTI_Char:
          begin
            Work^.CajVariant := CreateCajVariant(CSV_String, 0);
            Work^.TType := 0;
            Work^.CajVariant^.CV_Str := ParseString;
            if not DoPreCalc then
            begin
              DestroyCajVariant(Work^.CajVariant);
              Dispose(Work);
              DisposeList;
              Exit;
            end; {if}
            Items.Add(Work);
          end; {CSTI_String}
        CSTI_HexInt:
          begin
            Work^.TType := 0;
            if (Res^.VType >= csv_SByte) and (Res^.VType <= Csv_SInt32) then
              Work^.CajVariant := CreateCajVariant(res^.VType, 0)
            else
              Work^.CajVariant := CreateCajVariant(csv_SInt32, 0);
            SetInteger(Work^.CajVariant, StrToInt(GetToken(Parser)));
            if not DoPreCalc then
            begin
              DestroyCajVariant(Work^.CajVariant);
              Dispose(Work);
              DisposeList;
              Exit;
            end; {if}
            NextNoJunk(Parser);
            Items.Add(Work);
          end; {CSTI_HexInt}
      else
        begin
          RunError(EErrorInExpression);
          Dispose(Work);
          DisposeList;
          Exit;
        end;
      end; {case}
    end {if}
    else
    begin
      New(Work);
      case Parser^.CurrTokenId of
        CSTI_Equal: Work^.TType := 13;
        CSTI_NotEqual: Work^.TType := 16;
        CSTI_Greater: Work^.TType := 14;
        CSTI_GreaterEqual: Work^.TType := 18;
        CSTI_Less: Work^.TType := 15;
        CSTI_LessEqual: Work^.TType := 17;
        CSTI_Plus: Work^.TType := 9;
        CSTI_Minus: Work^.TType := 10;
        CSTI_Divide:
          begin
            Work^.TType := 3;
            if Res^.VType = CSV_VAR then
              SetType(Res, CSV_Extended);
          end;
        CSTI_Multiply: Work^.TType := 2;
        CSTII_and: Work^.TType := 6;
        CSTII_div: Work^.TType := 4;
        CSTII_mod: Work^.TType := 5;
        CSTII_or: Work^.TType := 11;
        CSTII_shl: Work^.TType := 8;
        CSTII_shr: Work^.TType := 7;
        CSTII_xor: Work^.TType := 12;
      else
        begin
          RunError(EErrorInExpression);
          Dispose(Work);
          DisposeList;
          Exit;
        end; {else case}
      end; {case}
      Items.Add(Work);
      NextnoJunk(parser);
    end; {else if}
  end; {while}
  Calculate;
  if ErrorCode = 0 then
  begin
    if Items.Count <> 1 then
    begin
      RunError(EErrorInExpression);
      Calc := False;
    end else
    begin
      Work := Items.GetItem(0);
      if Perform(Res, Work^.CajVariant, PtSet) then
        Calc := True
      else RunError(ETypeMismatch);
    end; {if}
  end; {if}
  DisposeList;
end; {Calc}

function TCs2PascalScript.RunScriptProc(const Name: string; Parameters:
  PVariableManager): PCajVariant;
var
  ProcCall: LongInt;
  ProcDef: string;
  w: PCajVariant;
  i: LongInt;
  function IRem(S: string): string;
  {Remove the !}
  begin
    Delete(s, 1, 1);
    IRem := s;
  end; {irem}
begin
  RunScriptProc := nil;
  if MainOffset = -1 then
  begin
    Parser^.CurrTokenPos := -1;
    RunError(EBeginExpected);
    Exit;
  end; {if}
  if PM_Find(InternalProcedures, FastUpperCase(Name)) = -1 then
  begin
    RunError(EUnknownIdentifier);
    Exit;
  end; {if}
  ProcCall := LongInt(PM_Get(InternalProcedures, PM_Find(InternalProcedures,
    FastUpperCase(Name))));
  ProcDef := PM_GetSpec(InternalProcedures, PM_Find(InternalProcedures,
    FastUpperCase(Name)));
  if IntProcDefParam(ProcDef, -1) <> VM_Count(Parameters) then
  begin
    Parser^.CurrTokenPos := -1;
    RunError(EParameterError);
    Exit;
  end;
  for i := 1 to IntProcDefParam(ProcDef, -1) do begin
    if Pos('!', IntProcDefName(ProcDef, I)) = 1 then
    begin
      w := GetVarLink(VM_Get(Parameters, i - 1));
      if (w^.VType <> IntProcDefParam(ProcDef, I)) or ((W^.Flags and $1) <> 0)
        then
      begin
        Parser^.CurrTokenPos := I - 1;
        RunError(EParameterError);
        Exit;
      end; {if}
      VM_SetName(Parameters, I - 1, IRem(IntProcDefName(ProcDef, I)));
    end {if} else
    begin
      w := GetVarLink(VM_Get(Parameters, i - 1));
      if IntProcDefParam(ProcDef, i) <> w^.VType then
      begin
        Parser^.CurrTokenPos := I - 1;
        RunError(EParameterError);
        Exit;
      end; {if}
      VM_SetName(Parameters, I - 1, IntProcDefName(ProcDef, I));
    end; {else if}
  end; {for}
  if IntProcDefParam(ProcDef, 0) <> 0 then
  begin
    w := CreateCajVariant(IntProcDefParam(ProcDef, 0), 0);
    VM_Add(Parameters, CreateCajVariant(CSV_Var, 0), 'RESULT')^.Cv_Var := w;
  end {if}
  else w := nil;
  Parser^.CurrTokenPos := ProcCall;
  ParseToken(Parser);
  if Parser^.CurrTokenId = CSTII_Var then
  begin
    if not ProcessVars(Parameters) then
    begin
      DestroyCajVariant(w);
      Exit;
    end; {if}
  end; {if}
  if not RunBegin(Parameters, False) then
  begin
    DestroycajVariant(w);
    Exit;
  end; {if}
  ParseToken(Parser);
  RunScriptProc := w;
end;

function TCs2PascalScript.DoProc(Vars: PVariableManager; Internal: Boolean):
PCajVariant;
{Call an internal/external Procedure}
var
  ProcCall: TRegisteredProc;
  ProcCall2: LongInt;
  ProcDef: string;
  w: PCajVariant;
  i: LongInt;
  Params: PVariableManager;
  function IRem(S: string): string;
  {Remove the !}
  begin
    Delete(s, 1, 1);
    IRem := s;
  end; {irem}
begin
  DoProc := nil;
  if Internal then
  begin
    ProcCall2 := LongInt(PM_Get(InternalProcedures, PM_Find(InternalProcedures,
      FastUpperCase(GetToken(Parser)))));
    ProcDef := PM_GetSpec(InternalProcedures, PM_Find(InternalProcedures,
      FastUpperCase(GetToken(Parser))));
{$IFDEF FPC}
    ProcCall := TRegisteredProc(nil);
{$ELSE}
    ProcCall := nil;
{$ENDIF}
  end else
  begin
{$IFDEF FPC}
    ProcCall := TRegisteredProc(PM_Get(Procedures, PM_Find(Procedures,
      FastUpperCase(GetToken(Parser)))));
{$ELSE}
    @ProcCall := PM_Get(Procedures, PM_Find(Procedures,
      FastUpperCase(GetToken(Parser))));
{$ENDIF}
    ProcCall2 := 0;
    ProcDef := PM_GetSpec(Procedures, PM_Find(Procedures,
      FastUpperCase(GetToken(Parser))));
  end;
  Params := VM_Create(nil);
  NextnoJunk(Parser);
  if (IntProcDefParam(ProcDef, -1) <> 0) and (Parser^.CurrTokenId <>
    CSTI_OpenRound) then
  begin
    RunError(ERoundOpenExpected);
    VM_Destroy(params);
    Exit;
  end; {if}
  if (IntProcDefParam(ProcDef, -1) = 0) and (Parser^.CurrTokenId =
    CSTI_OpenRound) then
  begin
    RunError(ESemiColonExpected);
    VM_Destroy(params);
    Exit;
  end; {if}
  if Parser^.CurrTokenId = CSTI_OpenRound then
  begin
    for i := 1 to IntProcDefParam(ProcDef, -1) do begin
      NextNoJunk(Parser);
      if Pos('!', intProcDefName(ProcDef, i)) = 1 then
      begin
        {Expect a variable}
        if Assigned(Vars) and (VM_Find(Vars, FastUppercase(GetToken(Parser))) <>
          -1) then
          w := GetVarLink(VM_Get(Vars, VM_Find(Vars,
            FastUppercase(GetToken(Parser)))))
        else if VM_Find(Variables, FastUppercase(GetToken(Parser))) <> -1 then
          w := GetVarLink(VM_Get(Variables, VM_Find(Variables,
            FastUppercase(GetToken(Parser)))))
        else
        begin
          RunError(EVariableExpected);
          VM_Destroy(params);
          Exit;
        end; {else else if}
        if (w^.Flags and $1) <> 0 then
        begin
          RunError(EVariableExpected);
          VM_Destroy(params);
          Exit;
        end; {if}
        if IntProcDefParam(ProcDef, I) = CSV_Array then
        begin
          if w^.VType <> CSV_Array then
          begin
            RunError(ETypeMismatch);
            VM_Destroy(params);
            Exit;
          end;
        end else
        begin
          if not CalcArrayInt(Vars, w) then
          begin
            VM_Destroy(params);
            Exit;
          end;
          if w^.VType <> IntProcDefParam(ProcDef, I) then
          begin
            RunError(ETypeMismatch);
            VM_Destroy(params);
            Exit;
          end;
        end;
        VM_Add(Params, CreateCajVariant(CSV_Var, 0),
          FastUppercase(IRem(IntProcDefName(ProcDef, i))))^.Cv_var := w;
        NextNoJunk(Parser);
      end {if}
      else
      begin
        w := VM_Add(Params, CreateCajVariant(IntProcDefParam(ProcDef, i), 0),
          IntProcDefName(ProcDef, i));
        if not Calc(vars, w, CSTI_CloseRound) then
        begin
          VM_Destroy(params);
          Exit;
        end; {if}
      end; {else if}
      if i = IntProcDefParam(ProcDef, -1) then
      begin
        if parser^.CurrTokenId <> CSTI_CloseRound then
        begin
          RunError(ERoundCloseExpected);
          VM_Destroy(params);
          Exit;
        end; {if}
      end {if}
      else
      begin
        if parser^.CurrTokenId <> CSTI_Comma then
        begin
          RunError(ECommaExpected);
          VM_Destroy(params);
          Exit;
        end; {if}
      end; {else if}
    end; {for}
    NextNoJunk(Parser);
  end; {if}
  {Now we have all the parameters}
  if Internal then
  begin
    if IntProcDefParam(ProcDef, 0) <> 0 then
    begin
      w := CreateCajVariant(IntProcDefParam(ProcDef, 0), 0);
      VM_Add(Params, CreateCajVariant(CSV_Var, 0), 'RESULT')^.Cv_Var := w;
    end {if}
    else w := nil;
    i := Parser^.CurrTokenPos;
    Parser^.CurrTokenPos := ProcCall2;
    ParseToken(Parser);
    if Parser^.CurrTokenId = CSTII_Var then
    begin
      if not ProcessVars(Params) then
      begin
        DestroyCajVariant(w);
        Exit;
      end; {if}
    end; {if}
    if not RunBegin(Params, False) then
    begin
      DestroycajVariant(w);
      Exit;
    end; {if}
    Parser^.CurrTokenPos := I;
    ParseToken(Parser);
    DoProc := w;
    VM_Destroy(params);
  end {if}
  else
  begin
    if IntProcDefParam(ProcDef, 0) <> 0 then
      w := CreateCajVariant(IntProcDefParam(ProcDef, 0), 0)
    else
      w := nil;
    RunError(ProcCall(fId, IntProcDefName(ProcDef, 0), Params, w));
    if ErrorCode <> ENoError then
    begin
      VM_Destroy(params);
      DestroyCajVariant(w);
      Exit;
    end; {if}
    VM_Destroy(params);
    DoProc := w;
  end; {if}
end; {DoExternalProc}

function TCs2PascalScript.RunBegin(Vars: PVariableManager; Skip: Boolean):
Boolean;
      { Run the Script, this is the main part of the script engine }
var
  StopOnSemicolon: Boolean;
  c, c2: PCajVariant;
  IPos, IStart, II, IEnd: LongInt;
  B: Boolean;

begin
  RunBegin := False;
  if Skip then
  begin
    if Parser^.CurrTokenId = CSTII_Begin then
    begin
      NextNoJunk(Parser);
      IPos := 1;
      while True do begin
        if Parser^.CurrTokenId = CSTI_EOF then
        begin RunError(EUnexpectedEndOfFile); Exit; end;
        if Parser^.CurrTokenId = CSTI_SyntaxError then
        begin RunError(ESyntaxError); Exit; end;
        if Parser^.CurrTokenId = CSTI_CommentEOFError then
        begin RunError(ESyntaxError); Exit; end;
        if Parser^.CurrTokenId = CSTI_CharError then
        begin RunError(ESyntaxError); Exit; end;
        if Parser^.CurrTokenId = CSTI_StringError then
        begin RunError(EStringError); Exit; end;
        if Parser^.CurrTokenId = CSTII_Case then
          Inc(IPos);
        if Parser^.CurrTokenId = CSTII_Begin then
          Inc(IPos);
        if Parser^.CurrTokenId = CSTII_End then
        begin
          Dec(IPos);
          if IPos = 0 then
            Break;
        end;
        NextNoJunk(Parser);
      end; {While}
      NextNoJunk(Parser); {Skip end}
    end else
    begin
      IPos := 1;
      while True do begin
        if Parser^.CurrTokenId = CSTI_EOF then
        begin RunError(EUnexpectedEndOfFile); Exit; end;