cs2.pas

Delphi script parser

{
Cajscript 2 PascalScript
version: 2.16

Parts ready:
 - Calculation
 - Assignments (a:=b;)
 - External Procedure/Function calls
 - Sub Begins
 - If Then Else
 - Internal Procedure/Functions
 - Variable parameters for internal and extenal functions.
 - Internal Procedure calls from outside the script.
 - Documentation and examples
 - For/To/Downto/Do
 - Cajsoft STDLib
 - While/Begin/End
 - Case x Of/End
 - Array (Dynamic, only one dimensional)

To do:
 - PCode
 - Object orientation
 - Repeat/Until
}
unit CS2; {CajScript 2.0}
{$I CS2_DEF.INC}
interface
uses
  CS2_VAR, CS2_UTL;

type
{$IFDEF CLASS}
  TCs2PascalScript = class;
  PCs2PascalScript = TCs2PascalScript;
{$ELSE}
  PCs2PascalScript = ^TCs2PascalScript;
{$ENDIF}
  TOnUses = function(Id: Pointer; Sender: PCs2PascalScript; Name: string):
  TCs2Error;
  TOnRunLine = function(Id: Pointer; Sender: PCs2PascalScript; Position:
    Longint): TCs2Error;
  TCs2PascalScript = {$IFDEF CLASS}class{$ELSE}object{$ENDIF}
  Private
    FUses: TifStringList;
    InternalProcedures: PProcedureManager;

    Text: PChar;
    MainOffset: LongInt;
    FId: Pointer;
    Parser: PCs2PascalParser;
    FErrorPos: LongInt;
    FErrorCode: TCs2Error;
{$IFDEF CLASS}
    FOnUses: TOnUses;
    FOnRunLine: TOnRunLine;
{$ENDIF}
    function CalcArrayInt(Vars: PVariableManager; var W: PCajVariant): Boolean;
    function IdentifierExists(SubVars: PVariableManager; const S: string):
    Boolean;
    function ProcessVars(Vars: PVariableManager): Boolean;
    procedure RunError(C: TCs2Error);
    function RunBegin(Vars: PVariableManager; Skip: Boolean): Boolean;
    function Calc(Vars: PVariableManager; res: PCajVariant;
      StopOn: TCs2TokenId): Boolean;
    function DoProc(Vars: PVariableManager; Internal: Boolean): PCajVariant;
  Public
    Variables: PVariableManager;
    Procedures: PProcedureManager;
{$IFDEF CLASS}
    property GetText: Pchar read Text;
    property OnRunLine: TOnRunLine Read FOnRunLine Write FOnRunLine;
    property OnUses: TOnUses Read FOnUses Write FOnUses;
    property ErrorCode: TCs2Error Read FErrorCode;
    property ErrorPos: LongInt Read FErrorPos;
{$ELSE}
    OnUses: TOnUses;
    OnRunLine: TOnRunLine;
    function ErrorCode: TCs2Error;
    function ErrorPos: LongInt;
{$ENDIF}
    procedure RunScript;
    function RunScriptProc(const Name: string;
      Parameters: PVariableManager): PCajVariant;

    procedure SetText(p: Pchar);
    constructor Create(Id: Pointer);
    destructor Destroy; {$IFDEF CLASS}Override; {$ENDIF}
  end;

procedure RegisterStdLib(P: PCs2PascalScript);
{Register all standard functions:}
{
Install:
  Function StrGet(S : String; I : Integer) : Char;
  Function StrSet(c : Char; I : Integer; var s : String) : Char;
  Function Ord(C : Char) : Byte;
  Function Chr(B : Byte) : Char;
  Function StrToInt(s : string;def : Longint) : Longint;
  Function IntToStr(i : Longint) : String;
  Function Uppercase(s : string) : string;
  Function Copy(S : String; Indx, Count : Integer) : String;
  Procedure Delete(var S : String; Indx, Count : Integer);
  Function Pos(SubStr, S : String) : Integer;
  Procedure Insert(Source : String; var Dest : String; Indx : Integer);
  Procedure SetArrayLength(var Arr : Array; I : Longint);
  Function GetArrayLength(var Arr : Array) : Longint;
  Function Length(s : String) : Longint;
  Function Sin(e : Extended) : Extended;
  Function Cos(e : Extended) : Extended;
  Function Round(e : Extended) : Longint;
  Function Trunc(e : Extended) : Longint;
  Function Pi : Extended;
}

implementation
type
  TGTyperec = record
    ident: string[20];
    typeid: Word;
  end;
const
  GTypes: array[1..16] of TGTyperec = (
    (Ident: 'BYTE'; typeid: CSV_UByte),
    (Ident: 'SHORTINT'; typeid: CSV_SByte),
    (Ident: 'CHAR'; typeid: CSV_Char),
    (Ident: 'WORD'; typeid: CSV_UInt16),
    (Ident: 'SMALLINT'; typeid: CSV_SInt16),
    (Ident: 'CARDINAL'; typeid: CSV_UInt32),
    (Ident: 'LONGINT'; typeid: CSV_SInt32),
    (Ident: 'INTEGER'; typeid: CSV_SInt32),
    (Ident: 'STRING'; typeid: CSV_String),
    (Ident: 'REAL'; typeid: CSV_Real),
    (Ident: 'SINGLE'; typeid: CSV_Single),
    (Ident: 'DOUBLE'; typeid: CSV_Double),
    (Ident: 'EXTENDED'; typeid: CSV_Extended),
    (Ident: 'COMP'; typeid: CSV_Comp),
    (Ident: 'BOOLEAN'; typeid: CSV_Bool),
    (Ident: 'ARRAY'; typeid: CSV_Array));

function GetType(const s: string): Word;
var
  i: Integer;
begin
  for i := 1 to 16 do begin
    if s = GTypes[i].Ident then
    begin
      GetType := GTypes[i].typeid;
      Exit;
    end;
  end;
  GetType := 0;
end;

function IntToStr(I: LongInt): string;
var
  s: string;
begin
  Str(i, s);
  IntToStr := s;
end;

function StrToInt(const S: string): LongInt;
var
  e: Integer;
  Res: LongInt;
begin
  Val(S, Res, e);
  if e <> 0 then
    StrToInt := -1
  else
    StrToInt := Res;
end;

function StrToIntDef(const S: string; Def: LongInt): LongInt;
var
  e: Integer;
  Res: LongInt;
begin
  Val(S, Res, e);
  if e <> 0 then
    StrToIntDef := Def
  else
    StrToIntDef := Res;
end;

function StrToReal(const S: string): Extended;
var
  e: Integer;
  Res: Extended;
begin
  Val(S, Res, e);
  if e <> 0 then
    StrToReal := -1
  else
    StrToReal := Res;
end;


function IntProcDefParam(S: string; I: Integer): Integer;
{
Parse the incode-script procedure definition from a string.
When I=0 this function will return the result type.
When I=-1 this function will return the number of parameters.
When I=1 this function will return the first parameter type.
When I=2 this function will return the second parameter type.
etc.
}
var
  Res: Integer;
begin
  if I = 0 then
  {Return result-type} IntProcDefParam := StrToInt(Fw(s)) else
    if I = -1 then
    {Return param count} begin
      res := 0;
      Delete(S, 1, Length(Fw(s))); {result}
      Rs(S);
      Delete(S, 1, Length(Fw(s))); {name}
      Rs(S);
      while Length(s) > 0 do begin
        Inc(Res);
        Delete(S, 1, Length(Fw(s))); {Delete parameter name}
        Rs(S);
        Delete(S, 1, Length(Fw(s))); {Delete parameter type}
        Rs(S);
      end; {while}
      IntProcDefParam := Res;
    end {else if} else begin
      res := 0;
      if I < 1 then
      begin IntProcDefParam := -1; Exit; end;
      Delete(S, 1, Length(Fw(s))); {result}
      Rs(S);
      Delete(S, 1, Length(Fw(s))); {name}
      Rs(S);
      while Length(s) > 0 do begin
        Inc(Res);
        Delete(S, 1, Length(Fw(s))); {delete parameter name}
        Rs(S);
        if Res = I then
        begin IntProcDefParam := StrToInt(Fw(s)); Exit; end;
        Delete(S, 1, Length(Fw(s))); {delete type}
        Rs(S);
      end; {while}
      IntProcDefParam := 0;
    end {Else Else if}
end; {IntProcDefParam}

function IntProcDefName(S: string; I: Integer): string;
{
Parse the incode-script procedure definition from a string.
i=0 will return the procedure name
I=1 will return the first one
}
var
  Res: Integer;
begin
  res := 0;
  if i = 0 then
  begin
    Delete(S, 1, Length(Fw(s))); {result}
    Rs(S);
    IntProcDefName := fw(s);
    Exit;
  end;
  if I < 1 then
  begin IntProcDefName := ''; Exit; end;
  Delete(S, 1, Length(Fw(s))); {result}
  Rs(S);
  Delete(S, 1, Length(Fw(s))); {name}
  Rs(S);
  while Length(s) > 0 do begin
    Inc(Res);
    if Res = I then
    begin IntProcDefName := Fw(s); Exit; end;
    Delete(S, 1, Length(Fw(s))); {delete parameter name}
    Rs(S);
    Delete(S, 1, Length(Fw(s))); {delete type}
    Rs(S);
  end; {while}
  IntProcDefName := '';
end; {IntProcDefParam}

function TCs2PascalScript.CalcArrayInt(Vars: PVariableManager; var W:
  PCajVariant): Boolean;
{Calculate array [integer]}
var
  r: PCajVariant;
begin
  CalcArrayInt := False;
  while w^.VType = CSV_Array do begin
    NextNoJunk(Parser);
    if Parser^.CurrTokenId <> CSTI_OpenBlock then
    begin
      RunError(EOpenBlockExpected);
      Exit;
    end; {if}
    NextNoJunk(Parser);
    r := CreateCajVariant(CSV_SInt32, 0);
    if not Calc(Vars, r, CSTI_CloseBlock) then
    begin
      DestroyCajVariant(r);
      Exit;
    end; {if}
    if Parser^.CurrTokenID <> CSTI_CloseBlock then
    begin
      RunError(ECloseBlockExpected);
      DestroyCajVariant(r);
      Exit;
    end; {if}
    w := GetArrayItem(w, r^.CV_SInt32);
    DestroyCajVariant(r);
    if not Assigned(w) then
    begin
      RunError(EOutOfRange);
      Exit;
    end; {if}
  end;
  CalcArrayInt := True;
end; {CalcArrayInt}

function TCs2PascalScript.IdentifierExists(SubVars: PVariableManager; const S:
  string): Boolean;
{ Check if an identifier exists }
  function UsesExists(s: string): Boolean;
  var
    i: Integer;
  begin
    UsesExists := False;
    for i := 0 to FUses.Count - 1 do
      if FUses.GetItem(i) = s then
      begin
        UsesExists := True;
        Break;
      end;
  end; { UsesExists }

begin
  IdentifierExists := False;
  if UsesExists(FastUppercase(s)) then
    IdentifierExists := True
  else if PM_Find(Procedures, FastUppercase(s)) <> -1 then
    IdentifierExists := True
  else if PM_Find(InternalProcedures, FastUppercase(s)) <> -1 then
    IdentifierExists := True
  else if VM_Find(Variables, FastUppercase(s)) <> -1 then
    IdentifierExists := True
  else if GetType(FastUppercase(s)) <> 0 then
    IdentifierExists := True
  else if Assigned(SubVars) and (VM_Find(subVars, FastUppercase(s)) <> -1) then
  begin
    IdentifierExists := True
  end;
end; {IdentifierExists}


procedure TCs2PascalScript.SetText(p: PChar);
{ Assign a text to the script engine, this also checks for uses and variables. }
var
  HaveHadProgram,
    HaveHadUses: Boolean;

  function ProcessUses: Boolean;
  {Process Uses block}
  var
    i: Integer;
  begin
    ProcessUses := False;
    while Parser^.CurrTokenId <> CSTI_EOF do begin
      if Parser^.CurrTokenId <> CSTI_Identifier then
      begin
        RunError(EIdentifierExpected);
        Exit;
      end; {If}
      if IdentifierExists(nil, GetToken(Parser)) then
      begin
        RunError(EDuplicateIdentifier);
        Exit;
      end; {If}
      FUses.Add(FastUpperCase(GetToken(Parser)));
      if Assigned(OnUses) then
      begin
        i := OnUses(FId, {$IFNDEF CLASS}@{$ENDIF}Self, GetToken(Parser));
        if I <> ENoError then
        begin
          RunError(i);
          Exit;
        end; {If}
      end {If}
      else
      begin
        RunError(EUnknownIdentifier);
        Exit;
      end; {Else if}
      NextNoJunk(Parser);
      if (Parser^.CurrTokenId = CSTI_SemiColon) then
      begin
        NextNoJunk(Parser);
        Break;
      end {if}
      else if (Parser^.CurrTokenId <> CSTI_Comma) then
      begin
        RunError(EDuplicateIdentifier);
        Exit;
      end; {Else if}
    end;
    if Parser^.CurrTokenId = CSTI_EOF then
    begin
      RunError(EUnexpectedEndOfFile);
    end {If}
    else
    begin
      ProcessUses := True;
    end; {Else If}
  end; {ProcessUses}

  function DoFuncHeader: Boolean;
  var
    FuncParam: string;
    FuncName: string;
    CurrVar: string;
    CurrType: Word;
    FuncRes: Word;
    function Duplic(S: string): Boolean;
    var
      s2, s3: string;
      i: Integer;
    begin
      if s = FuncName then
      begin
        Duplic := True;
        Exit;
      end; {if}
      if (funcRes <> 0) and (s = 'RESULT') then
      begin
        duplic := True;