cs2.pas

Delphi script parser

        Exit;
      end;
      s2 := CurrVar;
      while Pos('|', s2) > 0 do begin
        if Pos('!', s2) = 1 then
          Delete(s2, 1, 1);
        if Copy(s2, 1, Pos('|', s2) - 1) = s then
        begin
          Duplic := True;
          Exit;
        end; {if}
        Delete(s2, 1, Pos('|', s2));
      end; {while}
      s2 := '0 ' + FuncParam;
      for i := 1 to IntProcDefParam(s2, -1) do begin
        s3 := IntProcDefName(s2, 0);
        if Pos('!', s2) = 1 then
          Delete(s2, 1, 1);
        if s3 = s then
        begin
          Duplic := True;
          Exit;
        end; {if}
      end; {for}
      Duplic := False;
    end; {duplic}
  begin
    DoFuncHeader := False;
    if Parser^.CurrTokenId = CSTII_Procedure then
      FuncRes := 0
    else
      FuncRes := 1;
    NextNoJunk(Parser);
    if Parser^.CurrTokenId <> CSTI_Identifier then
    begin
      RunError(EIdentifierExpected);
      Exit;
    end; {if}
    if IdentifierExists(nil, GetToken(Parser)) then
    begin
      RunError(EDuplicateIdentifier);
      Exit;
    end; {if}
    FuncName := FastUppercase(GetToken(Parser));
    FuncParam := FuncName;
    CurrVar := '';
    NextNoJunk(Parser);
    if parser^.CurrTokenId = CSTI_OpenRound then
    begin
      while True do begin
        NextNoJunk(Parser);
        if Parser^.CurrTokenId = CSTII_Var then
        begin
          CurrVar := '!';
          NextNoJunk(Parser);
        end; {if}
        while True do begin
          if Parser^.CurrTokenId <> CSTI_Identifier then
          begin
            RunError(EIdentifierExpected);
            Exit;
          end; {if}
          if IdentifierExists(nil, GetToken(Parser)) or Duplic(GetToken(Parser))
            then
          begin
            RunError(EDuplicateIdentifier);
            Exit;
          end; {if}
          CurrVar := CurrVar + fastuppercase(GetToken(Parser)) + '|';
          NextNoJunk(parser);
          if Parser^.CurrTokenId = CSTI_Colon then
            Break;
          if Parser^.CurrTokenId <> CSTI_Comma then
          begin
            RunError(ECommaExpected);
            Exit;
          end; {if}
          NextNoJunk(Parser);
        end; {while}
        NextNoJunk(Parser);
        CurrType := GetType(FastUppercase(GetToken(Parser)));
        if CurrType = 0 then
        begin
          RunError(EUnknownIdentifier);
          Exit;
        end; {if}
        if Pos('!', CurrVar) = 1 then
        begin
          Delete(currVar, 1, 1);
          while Pos('|', CurrVar) > 0 do begin
            FuncParam := FuncParam + ' !' + Copy(CurrVar, 1, Pos('|', CurrVar) -
              1) + ' ' + IntToStr(CurrType);
            Delete(CurrVar, 1, Pos('|', CurrVar));
          end; {while}
        end else
        begin
          while Pos('|', CurrVar) > 0 do begin
            FuncParam := FuncParam + ' ' + Copy(CurrVar, 1, Pos('|', CurrVar) -
              1) + ' ' + IntToStr(CurrType);
            Delete(CurrVar, 1, Pos('|', CurrVar));
          end; {while}
        end; {if}
        NextNoJunk(Parser);
        if Parser^.CurrTokenId = CSTI_CloseRound then
        begin
          NextNoJunk(Parser);
          Break;
        end; {if}
        if Parser^.CurrTokenId <> CSTI_SemiColon then
        begin
          RunError(ESemiColonExpected);
          Exit;
        end; {if}
        NextNoJunk(Parser);
      end; {while}
    end; {if}
    if FuncRes = 1 then
    begin
      if Parser^.CurrTokenId <> CSTI_Colon then
      begin
        RunError(EColonExpected);
        Exit;
      end;
      NextNoJunk(Parser);
      if Parser^.CurrTokenId <> CSTI_Identifier then
      begin
        RunError(EIdentifierExpected);
        Exit;
      end;
      FuncRes := GetType(FastUppercase(GetToken(Parser)));
      if FuncRes = 0 then
      begin
        RunError(EUnknownIdentifier);
        Exit;
      end;
      NextNoJunk(parser);
    end;
    FuncParam := InttoStr(FuncRes) + ' ' + FuncParam;
    if Parser^.CurrTokenId <> CSTI_Semicolon then
    begin
      RunError(ESemiColonExpected);
      Exit;
    end;
    NextNoJunk(Parser);
    PM_Add(InternalProcedures, FuncParam, Pointer(Parser^.CurrTokenPos));
    DoFuncHeader := True;
    if Parser^.CurrTokenId = CSTII_Var then
    begin
      while (Parser^.CurrTokenID <> CSTII_Begin) and (Parser^.CurrTokenID <>
        CSTI_EOF) do
        NextNoJunk(Parser);
    end;
    RunBegin(nil, True);
    if Parser^.CurrTokenId <> CSTI_Semicolon then
    begin
      RunError(ESemiColonExpected);
      Exit;
    end;
    NextNoJunk(Parser);
  end; {DoFuncHeader}

begin
  FUses.Clear;
  VM_Clear(Variables);
  Vm_Add(Variables, CreateBool(True), 'TRUE')^.Flags := 1;
  Vm_Add(Variables, CreateBool(False), 'FALSE')^.Flags := 1;
  PM_Clear(Procedures);
  PM_Clear(InternalProcedures);
  FUses.Add('SYSTEM');
  if Assigned(OnUses) then
    OnUses(fId, {$IFNDEF CLASS}@{$ENDIF}Self, 'SYSTEM');

  RunError(ENoError);
  MainOffset := -1;
  Text := p;
  if Text = nil then
  begin
    Exit;
  end; {If}
  Parser^.Text := Text;
  Parser^.CurrTokenPos := 0;
  HaveHadProgram := False;
  HaveHadUses := False;
  ParseToken(Parser);
  if (Parser^.CurrTokenId = CSTI_WhiteSpace) or (Parser^.CurrTokenId =
    CSTI_Comment) then
    NextNoJunk(Parser);
  while Parser^.CurrTokenId <> CSTI_EOF do begin
    case Parser^.CurrTokenId of
      CSTI_CommentEOFError,
        CSTI_CharError,
        CSTI_SyntaxError: begin RunError(ESyntaxError); Exit; end;
      CSTI_StringError: begin RunError(EStringError); Exit; end;
    end;
    if (Parser^.CurrTokenId = CSTII_Program) and (HaveHadProgram = False) and
      (HaveHadUses = False) then
    begin
      NextNoJunk(Parser);
      if Parser^.CurrTokenId <> CSTI_Identifier then
      begin
        RunError(EIdentifierExpected);
        Exit;
      end; {if}
      NextNoJunk(Parser);
      if Parser^.CurrTokenId <> CSTI_Semicolon then
      begin
        RunError(ESemicolonExpected);
        Exit;
      end; {if}
      NextNoJunk(Parser);
      HaveHadProgram := True;
    end {if}
    else if (Parser^.CurrTokenId = CSTII_Uses) and (HaveHadUses = False) then
    begin
      NextNoJunk(Parser);
      if not ProcessUses then
        Exit;
      HaveHadUses := True;
    end {else if}
    else if (Parser^.CurrTokenId = CSTII_Var) then
    begin
      if not ProcessVars(Variables) then
        Exit;
    end {Else if}
    else if (Parser^.CurrTokenId = CSTII_Procedure) or
      (Parser^.CurrTokenId = CSTII_Function)
      then
    begin
      if not DoFuncHeader then
        Exit;
    end {else if}
    else if (Parser^.CurrTokenId = CSTII_Begin) then
    begin
      MainOffset := Parser^.CurrTokenPos;
      Exit;
    end {Else if}
    else if (Parser^.CurrTokenId = CSTI_EOF) then
    begin
      RunError(EUnexpectedEndOfFile);
    end {Else if}
    else
    begin
      RunError(EBeginExpected);
      Exit;
    end; {Else If}
  end; {While}
end; {SetText}


function TCs2PascalScript.ProcessVars(Vars: PVariableManager): Boolean;
        { Process Vars block }
var
  Names: string;
  AType: Word;
  ArrVType: Word;
begin
  NextNojunk(Parser);
  Names := '';
  ProcessVars := False;
  while True do begin
    case Parser^.CurrTokenId of
      CSTI_CommentEOFError,
        CSTI_CharError,
        CSTI_SyntaxError: begin RunError(ESyntaxError); Exit; end;
      CSTI_StringError: begin RunError(EStringError); Exit; end;
      CSTI_EOF: begin RunError(EUnexpectedEndOfFile); Exit; end;
    end;
    if Parser^.CurrTokenId <> CSTI_Identifier then
    begin
      RunError(EIdentifierExpected);
      Exit;
    end;
    if IdentifierExists(Vars, GetToken(Parser)) then
    begin
      RunError(EDuplicateIdentifier);
      Exit;
    end; {if}

    Names := Names + FastUpperCase(GetToken(Parser)) + '|';
    NextNoJunk(Parser);
    while Parser^.CurrTokenId = CSTI_Comma do begin
      NextNoJunk(Parser);
      if Parser^.CurrTokenId <> CSTI_Identifier then
      begin
        RunError(EIdentifierExpected);
        Exit;
      end; {if}
      if IdentifierExists(nil, GetToken(Parser)) then
      begin
        RunError(EDuplicateIdentifier);
        Exit;
      end; {if}
      Names := Names + FastUpperCase(GetToken(Parser)) + '|';
      NextNoJunk(Parser);
    end; {while}
    if Parser^.CurrTokenId <> CSTI_Colon then
    begin
      RunError(EColonExpected);
      Exit;
    end; {if}
    NextNoJunk(Parser);
    if Parser^.CurrTokenId = CSTI_Identifier then
    begin
      AType := GetType(FastUpperCase(GetToken(Parser)));
      if AType = 0 then
      begin
        RunError(EUnknownIdentifier);
        Exit;
      end; {if}
      if AType = CSV_Array then
      begin
        NextNoJunk(Parser);
        if Parser^.CurrTokenId <> CSTII_Of then
        begin
          RunError(EOfExpected);
          Exit;
        end;
        NextNoJunk(Parser);
        ArrVType := GetType(FastUpperCase(GetToken(Parser)));
        if ArrVType = 0 then
        begin
          RunError(EUnknownIdentifier);
          Exit;
        end; {if}
      end else ArrVType := 0;
      while Pos('|', names) > 0 do begin
        VM_Add(Vars, CreateCajVariant(AType, ArrVType), Copy(names, 1, Pos('|',
          names) - 1));
        Delete(Names, 1, Pos('|', Names));
      end; {if}
    end {else if}
    else
    begin
      RunError(EIdentifierExpected);
      Exit;
    end; {if}
    NextNoJunk(Parser);
    if Parser^.CurrTokenId <> CSTI_Semicolon then
    begin
      RunError(ESemicolonExpected);
      Exit;
    end; {if}
    NextNoJunk(Parser);
    if Parser^.CurrTokenId <> CSTI_Identifier then
      Break;
  end; {while}
  ProcessVars := True;
end; {ProcessVars}

constructor TCs2PascalScript.Create(Id: Pointer);
begin
{$IFDEF CLASS}
  inherited Create;
{$ENDIF}
  FUses.Create;
  New(Parser);
  FId := Id;
  RunError(ENoError);
  Text := nil;
  MainOffset := -1;
  Procedures := PM_Create;
  InternalProcedures := PM_Create;
  Variables := VM_Create(nil);
  OnUses := nil;
  OnRunLine := nil;
end; {Create}

destructor TCs2PascalScript.Destroy;
begin
  Dispose(Parser);
  VM_Destroy(Variables);
  PM_Destroy(InternalProcedures);
  PM_Destroy(Procedures);
  FUses.Destroy;
{$IFDEF CLASS}
  inherited Destroy;
{$ENDIF}
end; {Create}

{$IFNDEF CLASS}

function TCs2PascalScript.ErrorCode: TCs2Error;
{ Return the error code }
begin
  ErrorCode := FErrorCode;
end; {Errorcode}

function TCs2PascalScript.ErrorPos: LongInt;
{ Return the error position }
begin
  ErrorPos := FErrorPos;
end; {ErrorPos}

{$ENDIF}

procedure TCs2PascalScript.RunError(C: TCs2Error);
{ Run an error }
begin
  if c = ENoError then
  begin
    FErrorCode := C;
    FErrorPos := -1;
  end {if}
  else
  begin
    FErrorCode := C;
    FErrorPos := Parser^.CurrTokenPos;
  end; {else if}
end; {RunError}

procedure TCs2PascalScript.RunScript;
{ Run the script! }
begin
  if MainOffset = -1 then
  begin
    Exit;
  end; {if}
  RunError(ENoError);
  Parser^.CurrTokenPos := MainOffset;
  ParseToken(Parser);
  if RunBegin(nil, False) then
  begin
    if Parser^.CurrTokenId <> CSTI_Period then
    begin
      RunError(EPeriodExpected);
    end;
  end;
end; {RunScript}

type
  PCajSmallCalculation = ^TCajSmallCalculation;
  TCajSmallCalculation = packed record
    TType: Byte;
                                  {
                                  0 = Variant

                                  2 = *