cs2_utl.pas

Delphi script parser

unit CS2_UTL; {Cajscript 2.0 Utilities (Parser, Pascal:TList, TStringlist)}
{$I CS2_DEF.INC}
interface

type
  TCs2TokenId = (
  {Errors}
    CSTI_SyntaxError,
    CSTI_CommentEOFError,
    CSTI_CharError,
    CSTI_StringError,
  {Tokens}
    CSTI_EOF,
    CSTI_Whitespace,
    CSTI_Comment,
    CSTI_Identifier,
    CSTI_SemiColon,
    CSTI_Comma,
    CSTI_Period,
    CSTI_Colon,
    CSTI_OpenRound,
    CSTI_CloseRound,
    CSTI_OpenBlock,
    CSTI_CloseBlock,
    CSTI_Assignment,
    CSTI_Equal,
    CSTI_NotEqual,
    CSTI_Greater,
    CSTI_GreaterEqual,
    CSTI_Less,
    CSTI_LessEqual,
    CSTI_Plus,
    CSTI_Minus,
    CSTI_Divide,
    CSTI_Multiply,
    CSTI_Integer,
    CSTI_Real,
    CSTI_String,
    CSTI_Char,
    CSTI_HexInt,
  {Identifiers}
    CSTII_and,
    CSTII_begin,
    CSTII_case,
    CSTII_const,
    CSTII_div,
    CSTII_do,
    CSTII_downto,
    CSTII_else
    ,
    CSTII_end,
    CSTII_for,
    CSTII_function,
    CSTII_if,
    CSTII_in,
    CSTII_mod,
    CSTII_not,
    CSTII_of,
    CSTII_or,
    CSTII_procedure,
    CSTII_program,
    CSTII_repeat,
    CSTII_set,
    CSTII_shl,
    CSTII_shr,
    CSTII_string,
    CSTII_then,
    CSTII_to,
    CSTII_type,
    CSTII_until,
    CSTII_uses,
    CSTII_var,
    CSTII_while,
    CSTII_with,
    CSTII_xor
    );
  PCs2PascalParser = ^TCs2PascalParser;
  TCs2PascalParser = record
    CurrTokenId: TCs2Tokenid;
    CurrTokenLen: LongInt;
    CurrTokenPos: LongInt;
    Text: PChar;
  end;

procedure NextNoJunk(data: PCs2PascalParser);
{Go to the next nojunk token}
function GetToken(data: PCs2PascalParser): string;
{Return the token}
procedure ParseToken(data: PCs2PascalParser);
{Parse at active position}

type
  PIfListItem = ^TIfListItem;
  TIfListItem = record
    Next: PIfListItem;
    Prev: PIfListItem;
    Ptr: Pointer;
  end;
  TIfList = object
  Private
    FCount: LongInt;
    RootItem: PIfListItem;
    CurrItem: PIfListItem;
    currItemIdx: Longint;
  Public
    function Count: LongInt;
    function GetItem(Nr: LongInt): Pointer;
    procedure SetItem(Nr: LongInt; P: Pointer);
    procedure Add(P: Pointer);
    procedure Remove(P: Pointer);
    procedure Delete(Nr: Longint);
    procedure Clear;
    constructor Create;
    destructor Destroy;
  end;

  TIfStringList = object
  Private
    List: TIfList;
  Public
    function Count: LongInt;
    function GetItem(Nr: LongInt): string;
    procedure SetItem(Nr: LongInt; const s: string);
    procedure Add(const P: string);
    procedure Delete(NR: LongInt);
    procedure Clear;
    constructor Create;
    destructor Destroy;
  end;

function FastUpperCase(const s: string): string;
{Fast uppercase}

function Fw(const S: string): string;
{
First word
}
procedure Rs(var S: string);
{
  Remove space left (TrimLeft)
}
implementation

function Fw(const S: string): string;
{
First word
}
begin
  if Pos(' ', s) > 0 then
    Fw := Copy(S, 1, Pos(' ', s) - 1)
  else

    Fw := S;
end;

procedure Rs(var S: string);
{
  Remove space left (TrimLeft)
}
begin
  while (Length(s) > 0) do begin
    if s[1] = ' ' then
      Delete(S, 1, 1)
    else
      Break;
  end;
end;


constructor TIfList.Create;
begin
  FCount := 0;
  RootItem := nil;
  CurrItem := nil;
  curritemidx := -1;
end;

procedure TIfList.Add(P: Pointer);
var
  w: PIfListItem;
begin
  if RootItem = nil then
  begin
    new(rootitem);
    rootitem^.prev := nil;
    rootitem^.next := nil;
    rootitem^.Ptr := p;
    CurrItem := rootitem;
    curritemidx := 0;
    inc(fcount);
  end else
  begin
    while assigned(CurrItem^.next) do begin
      inc(CurrItemIdx);
      curritem := curritem^.next;
    end;
    new(w);
    curritem^.next := w;
    w^.Next := nil;
    w^.prev := curritem;
    w^.Ptr := p;
    inc(fcount);
  end;
end;

procedure TIfList.Delete(Nr: Longint);
begin
  if not Assigned(RootItem) or (nr >= fCount) then
    Exit;
  if nr < curritemidx then
  begin
    CurrItem := RootItem;
    CurrItemIdx := 0;
  end;
  while curritemidx < nr do begin
    CurrItem := CurrItem^.Next;
    Inc(CurrItemIdx);
  end;
  if assigned(curritem^.prev) then
  begin
    curritem^.prev^.next := curritem^.next;
    if assigned(CurrItem^.next) then
      curritem^.next^.prev := currItem^.prev;
  end
  else

  begin
    rootitem := curritem^.next;
    if assigned(curritem^.next) then
      curritem^.next^.prev := nil;
  end;
  dispose(curritem);
  currItemIdx := 0;
  CurrItem := rootitem;
  dec(fcount);
end;

procedure TIfList.Remove(P: Pointer);
begin
  CurrItem := rootitem;
  while assigned(curritem) do
  begin
    if curritem^.Ptr = p then
    begin
      if assigned(curritem^.prev) then
      begin
        curritem^.prev^.next := curritem^.next;
        if assigned(CurrItem^.next) then
          curritem^.next^.prev := currItem^.prev;
      end
      else

      begin
        rootitem := curritem^.next;
        if assigned(curritem^.next) then
          curritem^.next^.prev := nil;
      end;
      dispose(curritem);
      dec(fcount);
      break;
    end;
    curritem := curritem^.next;
  end;
  currItemIdx := 0;
  CurrItem := rootitem;
end;

procedure TIfList.Clear;
begin
  curritem := rootitem;
  while assigned(curritem) do begin
    if assigned(curritem^.next) then
    begin
      curritem := curritem^.next;
      dispose(curritem^.prev);
    end else
    begin
      dispose(curritem);
      curritem := nil;
    end;
  end;
  rootitem := nil;
  curritem := nil;
  curritemidx := -1;
  fcount := 0;
end;

destructor TIfList.Destroy;
begin
  clear;
end;

procedure TIfList.SetItem(Nr: LongInt; P: Pointer);
begin
  if not Assigned(RootItem) or (nr >= fCount) then
    Exit;
  if nr < curritemidx then
  begin
    CurrItem := RootItem;
    CurrItemIdx := 0;
  end;
  while curritemidx < nr do begin
    CurrItem := CurrItem^.Next;
    Inc(CurrItemIdx);
  end;
  CurrItem^.Ptr := p;
end;

function TifList.GetItem(Nr: LongInt): Pointer;
begin
  getitem := nil;
  if not Assigned(RootItem) or (nr >= fCount) then
    Exit;
  if nr < curritemidx then
  begin
    CurrItem := RootItem;
    CurrItemIdx := 0;
  end;
  while curritemidx < nr do begin
    CurrItem := CurrItem^.Next;
    Inc(CurrItemIdx);
  end;
  getitem := CurrItem^.Ptr;
end;

function TifList.Count: LongInt;
begin
  count := Fcount;
end;


function TIfStringList.Count: LongInt;
begin
  count := List.count;
end;
{$IFDEF SS}
type TsmallStr = record
    Size: Byte;
    Str: array[1..255] of Char;
  end;

function TifStringList.GetItem(Nr: LongInt): string;
var S: ^TSMALLSTR;
  tel: Byte;
begin
  getitem := '';
  s := List.GetItem(Nr);
  if s = nilthen
    Exit;
  GetItem[0] := Chr(S^.Size);
  for tel := 1 to S^.Size do
    GetItem[tel] := S^.Str[tel];
end;

procedure TifStringList.SetItem(Nr: LongInt; const s: string);
var
  p: ^TSMALLSTR;
  tel: LongInt;
begin
  p := List.GetItem(Nr);
  if p = nilthen
    Exit;
  FreeMem(p, p^.Size + 1);
  GetMem(p, Length(s) + 1);
  p^.Size := Length(s);
  for tel := 1 to p^.Size do
    p^.Str[tel] := s[tel];
  List.SetItem(Nr, p);
end;

procedure TifStringList.Add(const P: string);
var S: ^TSMALLSTR;
  tel: Byte;
begin
  GetMem(S, 1 + Length(P));
  s^.Size := Length(p);
  for tel := 1 to s^.Size do
    s^.Str[tel] := p[tel];
  List.Add(S);
end;

procedure TifStringList.Delete(NR: LongInt);
var P: ^TSMALLSTR;
begin
  p := list.getitem(nr);
  list.Remove(P);
  dispose(p);
end;

{$else
}
type pStr = ^string;

function TifStringList.GetItem(Nr: LongInt): string;
var
  S: PStr;
begin
  s := List.GetItem(Nr);
  if s = nil then
    Result := ''
  else

    Result := s^;
end;

procedure TifStringList.SetItem(Nr: LongInt; const s: string);
var
  p: PStr;
begin
  p := List.GetItem(Nr);
  if p = nil
    then
    Exit;
  p^ := s;
end;

procedure TifStringList.Add(const P: string);
var
  w: PStr;
begin
  new(w);
  w^ := p;
  List.Add(w);
end;

procedure TifStringList.Delete(NR: LongInt);
var
  W: PStr;
begin
  W := list.getitem(nr);
  if assigned(w) then
  begin
    dispose(w);
    list.Delete(Nr);
  end;
end;
{$ENDIF}

procedure TifStringList.Clear;
begin
  while List.Count > 0 do Delete(0);
end;

constructor TifStringList.Create;
begin
  List.Create;
end;

destructor TifStringList.Destroy;
var I: LongInt;
begin
  for I := 0 to list.count - 1 do
    Delete(I);
  List.Destroy;
end;

const chartab: array[Char] of Char = (
{Char tab is used for making a string in uppercase. This way is much faster}
    #0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15, #16,
    #17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29, #30, #31,
    #32, #33, #34, #35, #36, #37, #38, #39, #40, #41, #42, #43, #44, #45, #46,
    #47, #48, #49, #50, #51, #52, #53, #54, #55, #56, #57, #58, #59, #60, #61,
    #62, #63, #64, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74, #75, #76,
    #77, #78, #79, #80, #81, #82, #83, #84, #85, #86, #87, #88, #89, #90, #91,
    #92, #93, #94, #95, #96, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74,