Missing units

Projects/SAMufasaGUI/ValistusDefines.inc

@@ -0,0 +1,7 @@
+//Code Insight
+{$DEFINE ciCHECKDUPLICATES}
+{$DEFINE D8_NEWER1}
+{$DEFINE D9_NEWER}
+{$DEFINE D10_NEWER}
+{.$DEFINE D11_NEWER}
+{.$DEFINE D12_NEWER}

Projects/SAMufasaGUI/v_Constants.pas

@@ -0,0 +1,18 @@
+unit v_Constants;
+
+interface
+
+//Code Insight Constants
+const
+  {$IFNDEF FPC}
+  LineEnding = #13#10;
+  {$ENDIF}
+
+  ci_RangeError = 'Array range error at "%s" in statement: "%s"';
+  ci_UnknownMember = 'Unknown member "%s" in statement: "%s"';
+  ci_UnknownStruct = 'Cannot find proper structure for "%s" in statement: "%s"';
+  ci_UnknownInclude = 'Unknown include "%s"';
+
+implementation
+
+end.

Projects/SAMufasaGUI/v_MiscFunctions.pas

@@ -0,0 +1,145 @@
+unit v_MiscFunctions;
+
+interface
+
+type
+  TStringArray = array of string;
+
+function Explode(Sep, s: string): TStringArray;
+function PrePrepareString(s: string): string;
+function PrepareString(s: string; out ArrayCount: Integer): string; overload;
+function PrepareString(s: string): string; overload;
+function GetFirstWord(s: string): string;
+function CompressWhiteSpace(s: string): string;
+
+implementation
+
+uses
+  SysUtils, StrUtils;
+
+function Explode(Sep, s: string): TStringArray;
+var
+  p1, p2: Integer;
+begin
+  SetLength(Result, 0);
+  s := s + Sep;
+  p1 := 1;
+  p2 := Pos(Sep, s);
+  while (p1 > 0) and (p2 > 0) do
+  begin
+    SetLength(Result, Length(Result) + 1);
+    Result[High(Result)] := Copy(s, p1, p2 - p1);
+    p1 := p2 + Length(Sep);
+    p2 := PosEx(Sep, s, p1 + 1);
+  end;
+end;
+
+function PrePrepareString(s: string): string;
+var
+  i: Integer;
+  BraceCount: Integer;
+begin
+  Result := '';
+  BraceCount := 0;
+  for i := 1 to Length(s) do
+    if (BraceCount = 0) and (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.', '[', ']']) then
+      Result := Result + s[i]
+    else if (s[i] = '(') then
+      Inc(BraceCount)
+    else if (s[i] = ')') then
+      Dec(BraceCount);
+end;
+
+function PrepareString(s: string; out ArrayCount: Integer): string; overload;
+var
+  i: Integer;
+  BraceCount, BracketCount: Integer;
+begin
+  Result := '';
+  BraceCount := 0;
+  BracketCount := 0;
+  ArrayCount := 0;
+  s := UpperCase(s);
+  for i := 1 to Length(s) do
+    if (BraceCount = 0) and (BracketCount = 0) and (s[i] in ['A'..'Z', '0'..'9', '_']) then
+      Result := Result + s[i]
+    else if (s[i] = '[') then
+    begin
+      if (BracketCount = 0) then
+        Inc(ArrayCount);
+      Inc(BracketCount);
+    end
+    else if (s[i] = ']') then
+      Dec(BracketCount)
+    else if (s[i] = '(') then
+      Inc(BraceCount)
+    else if (s[i] = ')') then
+      Dec(BraceCount);
+end;
+
+function PrepareString(s: string): string; overload;
+var
+  a: Integer;
+begin
+  Result := PrepareString(s, a);
+end;
+
+function GetFirstWord(s: string): string;
+var
+  i: Integer;
+begin
+  i := 1;
+  while (i <= Length(s)) and (s[i] in ['a'..'z', 'A'..'Z'])  do
+    Inc(i);
+  Result := Copy(s, 1, i - 1);
+end;
+
+function CompressWhiteSpace(s: string): string;
+
+  function GetNextChar(s: string; i: Integer; out c: Char): Boolean;
+  begin
+    Result := True;
+    c := #0;
+
+    while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do
+      Inc(i);
+    if (i <= Length(s)) then
+      c := s[i]
+    else
+      Result := False;
+  end;
+
+var
+  i: Integer;
+  c: Char;
+  LastSpace: Boolean;
+begin
+  Result := '';
+  i := 1;
+  LastSpace := False;
+  while (i <= Length(s)) do
+  begin
+    if (s[i] in [#10, #11, #13, #32]) then
+    begin
+      if (not LastSpace) and (GetNextChar(s, i, c) and (c in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then
+        Result := Result + ' ';
+      Inc(i);
+      while (i <= Length(s)) and (s[i] in [#10, #11, #13, #32]) do
+        Inc(i);
+      LastSpace := True;
+    end
+    else
+    begin
+      LastSpace := False;
+      Result := Result + s[i];
+      if (s[i] in [':', ';']) then
+      begin
+        Result := Result + ' ';
+        LastSpace := True;
+      end;
+      Inc(i);
+    end;
+  end;
+end;
+
+end.

Projects/SAMufasaGUI/v_autocompleteform.pas

@@ -0,0 +1,581 @@
+unit v_AutoCompleteForm;
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
+  StdCtrls, ExtCtrls,
+
+  {$IFDEF FPC}
+  LMessages,
+  lcltype
+  {$ELSE}
+  Windows,
+  Messages
+  {$ENDIF};
+
+type
+  TInsertProc = procedure(Str: string) of object;
+
+  TAutoCompleteListBox = class(TListBox)
+  protected
+    fIndexList: array of Integer;
+    fList: TStrings;
+    fInsertList: TStrings;
+    fFilter: string;
+
+    procedure setItemList(List: TStrings);
+    procedure setInsertList(List: TStrings);
+    procedure setFilter(Filter: string);
+
+    procedure DblClick; override;
+    procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override;
+    {$IFDEF FPC}
+    procedure WMEraseBkgnd(var message: TLMEraseBkgnd); message LM_ERASEBKGND;
+    procedure WMVScroll(var message: TLMVScroll); message LM_VSCROLL;
+    procedure CNChar(var message: TLMessage); message CN_CHAR;
+    {$ELSE}
+    procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
+    procedure WMVScroll(var message: TWMVScroll); message WM_VSCROLL;
+    procedure CNChar(var message: TMessage); message CN_CHAR;
+    {$ENDIF}
+  public
+    ColumnSizes: array of Integer;
+    Redirect: TWinControl;
+    InsertProc: TInsertProc;
+
+    procedure setLists(ItemList, InsertList: TStrings);
+    function getInsert: string;
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+  published
+    property ItemList: TStrings read fList write setItemList;
+    property InsertList: TStrings read fInsertList write setInsertList;
+    property Filter: string read fFilter write setFilter;
+  end;
+
+  TAutoCompletePopup = class(TForm)
+  protected
+    l: TAutoCompleteListBox;
+    procedure DoShow; override;
+
+    function getRedirect: TWinControl;
+    procedure setRedirect(Control: TWinControl);
+    function getInsertProc: TInsertProc;
+    procedure setInsertProc(Proc: TInsertProc);
+  public
+    constructor Create(TheOwner: TComponent); override;
+    procedure Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil); reintroduce;
+    procedure DoHide; override;
+
+    procedure HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+    procedure HandleKeyPress(Sender: TObject; var Key: char);
+  published
+    property ListBox: TAutoCompleteListBox read l;
+    property Redirect: TWinControl read getRedirect write setRedirect;
+    property InsertProc: TInsertProc read getInsertProc write setInsertProc;
+  end;
+
+  TParamHint = class(THintWindow)
+  public
+    constructor Create(TheOwner: TComponent); override;
+    procedure Paint; override;
+  end;
+
+implementation
+
+uses
+  StrUtils {$IFDEF FPC}, lclintf{$ENDIF}, Themes;
+
+procedure TAutoCompleteListBox.setItemList(List: TStrings);
+begin
+  fList.Assign(List);
+end;
+
+procedure TAutoCompleteListBox.setInsertList(List: TStrings);
+begin
+  fInsertList.Assign(List);
+end;
+
+procedure TAutoCompleteListBox.setLists(ItemList, InsertList: TStrings);
+var
+  i: Integer;
+begin
+  //fList.Assign(ItemList);
+  //fInsertList.Assign(InsertList);
+  {$IFDEF FPC}LockSelectionChange;{$ENDIF}
+
+  fList.BeginUpdate;
+  try
+    fList.Clear;
+    fList.AddStrings(ItemList);
+  finally
+    fList.EndUpdate;
+  end;
+
+  fInsertList.BeginUpdate;
+  try
+    fInsertList.Clear;
+    fInsertList.AddStrings(InsertList);
+  finally
+    fInsertList.EndUpdate;
+  end;
+
+  Items.BeginUpdate;
+  try
+    Items.Clear;
+    Items.AddStrings(ItemList);
+  finally
+    Items.EndUpdate;
+  end;
+
+  fFilter := '';
+
+  SetLength(fIndexList, fList.Count);
+  for i := 0 to fList.Count - 1 do
+    fIndexList[i] := i;
+
+  if (fList.Count > 0) then
+    ItemIndex := 0
+  else
+    ItemIndex := -1;
+
+  {$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
+end;
+
+procedure TAutoCompleteListBox.setFilter(Filter: string);
+var
+  i, c, l, del: Integer;
+begin
+  Filter := LowerCase(Filter);
+  if (Filter = fFilter) then
+    Exit;
+
+  {$IFDEF FPC}LockSelectionChange;{$ENDIF}
+
+  c := 0;
+  if (LeftStr(Filter, Length(fFilter)) = fFilter) then
+  begin
+    fFilter := Filter;
+
+    Items.BeginUpdate;
+    try
+      l := Length(fFilter);
+      del := 0;
+
+      for i := 0 to Items.Count - 1 do
+        if (LowerCase(LeftStr(fInsertList[fIndexList[i]], l)) <> fFilter) then
+        begin
+          Items.Delete(i - del);
+          Inc(del);
+        end
+        else
+        begin
+          if (ItemIndex = i) or (LowerCase(fInsertList[fIndexList[i]]) = fFilter) then
+            ItemIndex := c;
+
+          fIndexList[c] := fIndexList[i];
+          Inc(c);
+        end;
+
+      SetLength(fIndexList, c + 1);
+    finally
+      Items.EndUpdate;
+    end;
+  end
+  else
+  begin
+    fFilter := Filter;
+
+    Items.BeginUpdate;
+    try
+      Items.Clear;
+      l := Length(fFilter);
+      SetLength(fIndexList, fInsertList.Count);
+
+      for i := 0 to fInsertList.Count - 1 do
+        if (LowerCase(LeftStr(fInsertList[i], l)) = fFilter) then
+        begin
+          Items.Append(fList[i]);
+
+          if (LowerCase(fInsertList[i]) = fFilter) then
+            ItemIndex := i;
+
+          fIndexList[c] := i;
+          Inc(c);
+        end;
+      SetLength(fIndexList, c + 1);
+    finally
+      Items.EndUpdate;
+    end;
+  end;
+
+  {$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
+end;
+
+function TAutoCompleteListBox.getInsert: string;
+begin
+  if (ItemIndex < 0) or (ItemIndex > Length(fIndexList)) then
+    Result := ''
+  else
+    Result := fInsertList[fIndexList[ItemIndex]];
+end;
+
+{$IFDEF FPC}
+procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TLMEraseBkgnd);
+{$ELSE}
+procedure TAutoCompleteListBox.WMEraseBkgnd(var message: TWMEraseBkgnd);
+{$ENDIF}
+begin
+  if (Count < Round(Height / ItemHeight)) then
+  begin
+    Canvas.Brush.Color := clYellow;
+    FillRect(message.DC, Rect(0, Count * ItemHeight, Width, Height), HBRUSH({$IFDEF FPC}Brush.Reference.Handle{$ELSE}Parent.Brush.Handle{$ENDIF}));
+  end;
+
+  message.Result := 1;
+end;
+
+{$IFDEF FPC}
+procedure TAutoCompleteListBox.WMVScroll(var message: TLMVScroll);
+{$ELSE}
+procedure TAutoCompleteListBox.WMVScroll(var message: TWMVScroll);
+{$ENDIF}
+var
+  c: Integer;
+begin
+  {$IFDEF FPC}LockSelectionChange;{$ENDIF}
+  if (ItemIndex < TopIndex) then
+    ItemIndex := TopIndex
+  else
+  begin
+    c := Round(Height / ItemHeight) - 1;
+    if (ItemIndex > TopIndex + c) then
+      ItemIndex := TopIndex + c;
+  end;
+  {$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
+end;
+
+{$IFDEF FPC}
+procedure TAutoCompleteListBox.CNChar(var message: TLMessage);
+{$ELSE}
+procedure TAutoCompleteListBox.CNChar(var message: TMessage);
+{$ENDIF}
+begin
+  inherited;
+
+  {$IFDEF FPC}
+  if (message.Result = 0) and (Redirect <> nil) and (TLMChar(message).CharCode <> VK_DOWN) and (TLMChar(message).CharCode <> VK_UP) and (TLMChar(message).CharCode <> VK_RETURN) then
+  {$ELSE}
+  if (message.Result = 0) and (Redirect <> nil) and (TWMChar(message).CharCode <> VK_DOWN) and (TWMChar(message).CharCode <> VK_UP) and (TWMChar(message).CharCode <> VK_RETURN) then
+  {$ENDIF}
+  begin
+    Redirect.SetFocus;
+    Application.ProcessMessages;
+    SendMessage(Redirect.Handle, CN_Char, message.wParam, message.lParam);
+  end;
+end;
+
+procedure TAutoCompleteListBox.DblClick;
+begin
+  if (Assigned(InsertProc)) then
+    InsertProc(GetInsert);
+  if (Owner is TForm) then
+    TForm(Owner).Hide;
+end;
+
+procedure TAutoCompleteListBox.DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState);
+var
+  p1, p2, p3, tl, col: Integer;
+  s, c: string;
+begin
+  if (ItemIndex = -1) and (Count > 0) then
+  begin
+    {$IFDEF FPC}LockSelectionChange;{$ENDIF}
+    ItemIndex := TopIndex;
+    {$IFDEF FPC}UnlockSelectionChange;{$ENDIF}
+  end;
+
+  if {$IFDEF FPC}(odPainted in State) or{$ENDIF} (not Visible) or (ARect.Left > ClientRect.Right) or (ARect.Top > ClientRect.Bottom) or (Index < 0) or (Index >= Items.Count) then
+    Exit;
+
+  tl := ARect.Left;
+  col := 0;
+  with Canvas do
+  begin
+    Font.Style := [];
+    Font.Color := clBlack;
+    if (odSelected in State) then
+      Brush.Color := clHighlight
+    else if (odHotLight in State) then
+      Brush.Color := clHotLight
+    else if Odd(Index) then
+      Brush.Color := $F0F0F0
+    else
+      Brush.Color := clWhite;
+    FillRect(ARect);
+
+    s := Items[Index];
+    p1 := Pos('{', s);
+    p3 := 1;
+    while (p1 > 0) do
+    begin
+      p2 := PosEx('}', s, p1 + 1);
+      if (p2 > 0) then
+      begin
+        if (s[p2 - 1] <> '\') then
+        begin
+          c := Copy(s, p3, p1 - p3);
+          TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2) , c);
+          tl := tl + TextWidth(c) + 1;
+
+          p3 := p2 + 1;
+          if ((p2 - p1 - 2) > 0) then
+          begin
+            c := LowerCase(Copy(s, p1 + 2, p2 - p1 - 2));
+            case Char(CharUpper({$IFNDEF FPC}PChar{$ELSE}Char{$ENDIF}(s[p1 + 1]))) of
+              '#', 'C': Font.Color := StringToColor(c);
+              'B':
+                if (c = '+') then
+                  Font.Style := Font.Style + [fsBold]
+                else
+                  Font.Style := Font.Style - [fsBold];
+              'I':
+                if (c = '+') then
+                  Font.Style := Font.Style + [fsItalic]
+                else
+                  Font.Style := Font.Style - [fsItalic];
+              'U':
+                if (c = '+') then
+                  Font.Style := Font.Style + [fsUnderline]
+                else
+                  Font.Style := Font.Style - [fsUnderline];
+            end;
+          end
+          else if (s[p1 + 1] = '|') then
+          begin
+            if (ColumnSizes[col] = -1) then
+              ColumnSizes[col] := Canvas.TextWidth('constructor') + 5;
+            tl := ColumnSizes[col];
+            Inc(Col);
+          end;
+          p1 := PosEx('{', s, p2 + 1);
+        end;
+      end
+      else
+        Break;
+    end;
+
+    if ((Length(s) - p3 + 1) > 0) then
+    begin
+      c := Copy(s, p3, Length(s) - p3 + 1);
+      TextOut(tl, ARect.Top + Round((ItemHeight - TextHeight(c) + 0.001) / 2), c);
+    end;
+  end;
+end;
+
+constructor TAutoCompleteListBox.Create(TheOwner: TComponent);
+begin
+  inherited;
+
+  DoubleBuffered := True;
+  ControlStyle := ControlStyle + [csOpaque];
+  BorderStyle := bsNone;
+  Style := lbOwnerDrawFixed;
+
+  IntegralHeight := True;
+  {$IFDEF FPC}
+  ItemHeight := CalculateStandardItemHeight + 4;
+  {$ELSE}
+  ItemHeight := 19;
+  {$ENDIF}
+  Constraints.MinHeight := ItemHeight;
+
+  SetLength(ColumnSizes, 1);
+  ColumnSizes[0] := -1;
+  Redirect := nil;
+  InsertProc := nil;
+
+  Items.Clear;
+  fList := TStringList .Create;
+  fInsertList := TStringList.Create;
+  fFilter := '';
+end;
+
+destructor TAutoCompleteListBox.Destroy;
+begin
+  FreeAndNil(fList);
+  FreeAndNil(fInsertList);
+
+  inherited;
+end;
+
+procedure TAutoCompletePopup.DoShow;
+begin
+  //ClientHeight := Max(Min(Round(ClientHeight / l.ItemHeight), l.Count), 1) * l.ItemHeight;
+  //ClientHeight := Max(Round(ClientHeight / l.ItemHeight), 1) * l.ItemHeight;
+end;
+
+function TAutoCompletePopup.getRedirect: TWinControl;
+begin
+  Result := ListBox.Redirect;
+end;
+
+procedure TAutoCompletePopup.setRedirect(Control: TWinControl);
+begin
+  ListBox.Redirect := Control;
+end;
+
+function TAutoCompletePopup.getInsertProc: TInsertProc;
+begin
+  Result := ListBox.InsertProc;
+end;
+
+procedure TAutoCompletePopup.setInsertProc(Proc: TInsertProc);
+begin
+  ListBox.InsertProc := Proc;
+end;
+
+constructor TAutoCompletePopup.Create(TheOwner: TComponent);
+begin
+  inherited;
+
+  l := TAutoCompleteListBox.Create(Self);
+  with l do
+  begin
+    Parent := Self;
+    Align := alClient;
+    OnKeyDown := {$IFDEF FPC}@{$ENDIF}HandleKeyDown;
+    OnKeyPress := {$IFDEF FPC}@{$ENDIF}HandleKeyPress;
+  end;
+
+  DefaultMonitor := dmMainForm;
+  FormStyle := fsStayOnTop;
+
+  {$IFDEF FPC}
+  ShowInTaskBar := stNever;
+  {$ENDIF}
+
+  BorderStyle := bsSizeToolWin;
+  BorderIcons := [];
+  SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and (not WS_CAPTION) or WS_BORDER);
+  Height := Height - GetSystemMetrics(SM_CYCAPTION);
+
+  DoubleBuffered := True;
+  ControlStyle := ControlStyle + [csOpaque];
+
+  ClientHeight := Round(ClientHeight / l.ItemHeight) * l.ItemHeight;
+  Constraints.MinHeight := l.ItemHeight;
+  Constraints.MinWidth := 100;
+end;
+
+procedure TAutoCompletePopup.DoHide;
+begin
+  ListBox.Clear;
+  inherited;
+end;
+
+procedure TAutoCompletePopup.HandleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+begin
+  if Visible then
+  begin
+    case Key of
+      VK_UP:
+        if (ListBox.Count > 0) and (ListBox.ItemIndex > 0) then
+          ListBox.ItemIndex := ListBox.ItemIndex - 1;
+      VK_DOWN:
+        if (ListBox.Count > 0) and (ListBox.ItemIndex + 1 < ListBox.Count) then
+          ListBox.ItemIndex := ListBox.ItemIndex + 1;
+      VK_RETURN:
+        ListBox.DblClick;
+      VK_ESCAPE:
+        Hide;
+      else
+        Exit;
+    end;
+    Key := 0;
+  end;
+end;
+
+procedure TAutoCompletePopup.HandleKeyPress(Sender: TObject; var Key: char);
+begin
+  if Visible and (not (Key in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then
+    if (Key in ['.', '(', '[', ';', ':']) then
+      ListBox.DblClick
+    else
+      Hide;
+end;
+
+procedure TAutoCompletePopup.Show(Pos: TPoint; ItemList, InsertList: TStrings; Filter: string = ''; Editor: TWinControl = nil);
+begin
+  ListBox.setLists(ItemList, InsertList);
+  ListBox.Redirect := Editor;
+  ListBox.Filter := Filter;
+  Left := Pos.x;
+  Top := Pos.y;
+
+  inherited Show;
+
+  if (Editor <> nil) then
+    Editor.SetFocus;
+end;
+
+constructor TParamHint.Create(TheOwner: TComponent);
+begin
+  inherited;
+
+  {$IFDEF FPC}
+  AutoHide := False;
+  {$ENDIF}
+end;
+
+procedure TParamHint.Paint;
+
+  function GetDrawTextFlags: Cardinal;
+  var
+    EffectiveAlignment: TAlignment;
+  begin
+    Result := DT_NOPREFIX or DT_VCENTER or DT_WORDBREAK;
+    EffectiveAlignment := Alignment;
+    if BiDiMode <> bdLeftToRight then
+    begin
+      Result := Result or DT_RTLREADING;
+      //change alignment if is RTL
+      if BiDiMode = bdRightToLeft then
+      begin
+        case Alignment of
+          taLeftJustify: EffectiveAlignment := taRightJustify;
+          taRightJustify: EffectiveAlignment := taLeftJustify;
+        end;
+      end;
+    end;
+    case EffectiveAlignment of
+      taLeftJustify: Result := Result or DT_LEFT;
+      taCenter: Result := Result or DT_CENTER;
+      taRightJustify: Result := Result or DT_RIGHT;
+    end;
+end;
+
+var
+  ARect: TRect;
+  Details: TThemedElementDetails;
+begin
+  ARect := ClientRect;
+  if Color = clInfoBk then // draw using themes
+  begin
+    Details := ThemeServices.GetElementDetails(tttStandardLink);
+    ThemeServices.DrawElement(Canvas.Handle, Details, ARect);
+  end
+  else
+  begin
+    Canvas.Brush.Color := Color;
+    Canvas.Pen.Width := 1;
+    Canvas.FillRect(ARect);
+    DrawEdge(Canvas.Handle, ARect, BDR_RAISEDOUTER, BF_RECT);
+  end;
+  InflateRect(ARect, - 4, - 4);
+  Canvas.TextOut(ARect.Left, ARect.Top, Caption);
+end;
+
+end.
+

Units/Misc/CastaliaPasLexTypes.pas

@@ -0,0 +1,322 @@
+{---------------------------------------------------------------------------
+The contents of this file are subject to the Mozilla Public License Version
+1.1 (the "License"); you may not use this file except in compliance with the
+License. You may obtain a copy of the License at
+http://www.mozilla.org/NPL/NPL-1_1Final.html
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+the specific language governing rights and limitations under the License.
+
+The Original Code is: mwPasLexTypes, released November 14, 1999.
+
+The Initial Developer of the Original Code is Martin Waldenburg
+unit CastaliaPasLexTypes;
+
+----------------------------------------------------------------------------}
+
+unit CastaliaPasLexTypes;
+
+{$include ValistusDefines.inc}
+
+interface
+
+uses SysUtils, TypInfo;
+
+var
+  CompTable: array[#0..#255] of byte;
+
+type
+
+  TMessageEventType = ( meError, meNotSupported );
+
+  TMessageEvent = procedure(Sender: TObject; const Typ : TMessageEventType; const Msg: string; X, Y: Integer ) of object; //jdj 7/16/1999; DR 2001-11-06
+
+  TCommentState = (csAnsi, csBor, csNo);
+
+  TTokenPoint = packed record
+    X : Integer;
+    Y : Integer;
+  end;
+
+  TptTokenKind = (
+    tokAbort, //JThurman 2004-11-8 (flow control routines)
+    tokAbsolute,
+    tokAbstract,
+    tokAdd,
+    tokAddressOp,
+    tokAmpersand,
+    tokAnd,
+    tokAnsiComment,
+    tokAnsiString,
+    tokArray,
+    tokAs,
+    tokAsciiChar,
+    tokAsm,
+    tokAssembler,
+    tokAssign,
+    tokAt,
+    tokAutomated,
+    tokBegin,
+    tokBoolean,
+    tokBorComment,
+    tokBraceClose,
+    tokBraceOpen,
+    tokBreak, //JThurman 2004-11-8 (flow control routines)
+    tokByte,
+    tokByteBool,
+    tokCardinal,
+	tokCase,
+    tokCdecl,
+    tokChar,
+    tokClass,
+    tokClassForward,
+    tokClassFunction,
+    tokClassProcedure,
+    tokColon,
+    tokComma,
+    tokComp,
+    tokCompDirect,
+    tokConst,
+    tokConstructor,
+	tokContains,
+    tokContinue, //JThurman 2004-11-8 (flow control routines)
+	tokCRLF,
+	tokCRLFCo,
+	tokCurrency,
+	tokDefault,
+	tokDefineDirect,
+	tokDeprecated, // DR 2001-10-20
+    tokDestructor,
+    tokDispid,
+    tokDispinterface,
+    tokDiv,
+    tokDo,
+    tokDotDot,
+    tokDouble,
+    tokDoubleAddressOp,
+    tokDownto,
+    tokDWORD,
+    tokDynamic,
+    tokElse,
+    tokElseDirect,
+    tokEnd,
+    tokEndIfDirect,
+    tokEqual,
+    tokError,
+    tokExcept,
+    tokExit, //JThurman 2004-11-8 (flow control routine)
+    tokExport,
+    tokExports,
+    tokExtended,
+    tokExternal,
+    tokFar,
+	tokFile,
+  {$IFDEF D8_NEWER} //JThurman 2004-03-20
+  tokFinal,
+  {$ENDIF}
+    tokFinalization,
+    tokFinally,
+    tokFloat,
+    tokFor,
+    tokForward,
+    tokFunction,
+    tokGoto,
+    tokGreater,
+    tokGreaterEqual,
+  tokHalt, //JThurman 2004-11-8 (flow control routines)
+  {$IFDEF D8_NEWER} //JThurman 2004-04-06
+  tokHelper,
+  {$ENDIF}
+    tokIdentifier,
+    tokIf,
+    tokIfDirect,
+    tokIfEndDirect,
+    tokElseIfDirect,
+    tokIfDefDirect,
+    tokIfNDefDirect,
+    tokIfOptDirect,
+    tokImplementation,
+    tokImplements,
+    tokIn,
+    tokIncludeDirect,
+    tokIndex,
+    tokInherited,
+    tokInitialization,
+    tokInline,
+    tokInt64,
+    tokInteger,
+    tokIntegerConst,
+    tokInterface,
+    tokIs,
+    tokLabel,
+	tokLibrary,
+	tokLocal,  // DR 2001-11-14
+    tokLongBool,
+    tokLongint,
+    tokLongword,
+    tokLower,
+    tokLowerEqual,
+    tokMessage,
+    tokMinus,
+    tokMod,
+    tokName,
+    tokNear,
+    tokNil,
+    tokNodefault,
+    tokNone,
+    tokNot,
+    tokNotEqual,
+    tokNull,
+    tokObject,
+    tokOf,
+    tokOleVariant,
+    tokOn,
+  {$IFDEF D8_NEWER} //JThurman 2004-03-20
+  tokOperator,
+  {$ENDIF}
+    tokOr,
+    tokOut,
+    tokOverload,
+    tokOverride,
+    tokPackage,
+    tokPacked,
+    tokPascal,
+	tokPChar,
+	tokPlatform, // DR 2001-10-20
+    tokPlus,
+    tokPoint,
+    tokPointerSymbol,
+    tokPrivate,
+    tokProcedure,
+    tokProgram,
+    tokProperty,
+    tokProtected,
+    tokPublic,
+    tokPublished,
+    tokRaise,
+    tokRead,
+    tokReadonly,
+    tokReal,
+    tokReal48,
+    tokRecord,
+  {$IFDEF D12_NEWER}
+    tokReference, //JThurman 2008-25-07 (anonymous methods)
+  {$ENDIF}
+    tokRegister,
+    tokReintroduce,
+    tokRemove,
+    tokRepeat,
+    tokRequires,
+    tokResident,
+    tokResourceDirect,
+    tokResourcestring,
+    tokRoundClose,
+    tokRoundOpen,
+    tokRunError, //JThurman 2004-11-8 (flow control routines)
+    tokSafeCall,
+  {$IFDEF D8_NEWER} //JThurman 2004-03-19
+  tokSealed,
+  {$ENDIF}
+    tokSemiColon,
+    tokSet,
+	tokShl,
+    tokShortint,
+    tokShortString,
+    tokShr,
+    tokSingle,
+    tokSlash,
+    tokSlashesComment,
+    tokSmallint,
+    tokSpace,
+    tokSquareClose,
+    tokSquareOpen,
+    tokStar,
+  {$IFDEF D8_NEWER} //JThurman 2004-03-20
+  tokStatic,
+  {$ENDIF}
+    tokStdcall,
+    tokStored,
+  {$IFDEF D8_NEWER}
+  tokStrict, //JThurman 2004-03-03
+  {$ENDIF}
+    tokString,
+	tokStringConst,
+    tokStringDQConst,	// 2002-01-14	
+    tokStringresource,
+    tokSymbol,
+    tokThen,
+    tokThreadvar,
+    tokTo,
+    tokTry,
+    tokType,
+    tokUndefDirect,
+    tokUnit,
+    tokUnknown,
+  {$IFDEF D8_NEWER} //JThurman 2004-03-2003
+  tokUnsafe,
+  {$ENDIF}
+    tokUntil,
+    tokUses,
+	tokVar,
+	tokVarargs, // DR 2001-11-14
+    tokVariant,
+    tokVirtual,
+    tokWhile,
+    tokWideChar,
+    tokWideString,
+    tokWith,
+    tokWord,
+    tokWordBool,
+    tokWrite,
+    tokWriteonly,
+    tokXor,
+
+    tok_DONE);
+
+TmwPasLexStatus = record
+  CommentState: TCommentState;
+  ExID: TptTokenKind;
+  LineNumber: Integer;
+  LinePos: Integer;
+  Origin: PAnsiChar;
+  RunPos: Integer;
+  TokenPos: Integer;
+  TokenID: TptTokenKind;
+end;
+
+const ExTypes = [tokDWORD, tokUnknown];
+
+function TokenName(Value: TptTokenKind): string;
+function tokTokenName(Value: TptTokenKind): string;
+function IsTokenIDJunk(const aTokenID : TptTokenKind ) :Boolean; //XM 20001210
+
+implementation
+
+function TokenName(Value: TptTokenKind): string;
+begin //jdj 7/18/1999
+  Result := Copy(tokTokenName(Value), 4, MaxInt);
+end;
+
+function tokTokenName(Value: TptTokenKind): string;
+begin
+  result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value));
+end;
+
+function IsTokenIDJunk(const aTokenID : TptTokenKind ) :boolean; //XM 20001210
+begin
+  Result := aTokenID in [tokAnsiComment, tokBorComment, tokCRLF, tokCRLFCo, tokSlashesComment, tokSpace,
+    tokIfDirect,
+    tokIfEndDirect,
+    tokElseIfDirect,
+    tokIfDefDirect,
+    tokIfNDefDirect,
+    tokEndIfDirect,
+    tokIfOptDirect,
+    tokDefineDirect,
+    tokUndefDirect];
+end;
+
+
+end.
+

Units/Misc/CastaliaSimplePasParTypes.pas

@@ -0,0 +1,330 @@
+{---------------------------------------------------------------------------
+The contents of this file are subject to the Mozilla Public License Version
+1.1 (the "License"); you may not use this file except in compliance with the
+License. You may obtain a copy of the License at
+http://www.mozilla.org/NPL/NPL-1_1Final.html
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+the specific language governing rights and limitations under the License.
+
+The Original Code is: mwSimplePasParTypes, released November 14, 1999.
+
+The Initial Developer of the Original Code is Martin Waldenburg
+unit CastaliaPasLexTypes;
+
+----------------------------------------------------------------------------}
+
+unit CastaliaSimplePasParTypes;
+
+{$include ValistusDefines.inc}
+
+interface
+
+uses SysUtils, TypInfo;
+
+type
+  TmwParseError = (
+    InvalidAdditiveOperator,
+    InvalidAccessSpecifier,
+    InvalidCharString,
+    InvalidClassMethodHeading,
+    InvalidConstantDeclaration,
+    InvalidConstSection,
+    InvalidDeclarationSection,
+    InvalidDirective16Bit,
+    InvalidDirectiveBinding,
+    InvalidDirectiveCalling,
+    InvalidExportedHeading,
+    InvalidForStatement,
+    InvalidInitializationSection,
+    InvalidInterfaceDeclaration,
+    InvalidInterfaceType,
+    InvalidLabelId,
+    InvalidLabeledStatement,
+    InvalidMethodHeading,
+    InvalidMultiplicativeOperator,
+    InvalidNumber,
+    InvalidOrdinalIdentifier,
+    InvalidParameter,
+    InvalidParseFile,
+    InvalidProceduralDirective,
+    InvalidProceduralType,
+    InvalidProcedureDeclarationSection,
+    InvalidProcedureMethodDeclaration,
+    InvalidRealIdentifier,
+    InvalidRelativeOperator,
+    InvalidStorageSpecifier,
+    InvalidStringIdentifier,
+    InvalidStructuredType,
+    InvalidTryStatement,
+    InvalidTypeKind,
+    InvalidVariantIdentifier,
+    InvalidVarSection,
+    vchInvalidClass, //vch
+    vchInvalidMethod, //vch
+    vchInvalidProcedure,//vch
+    vchInvalidCircuit, //vch
+    vchInvalidIncludeFile //vch
+    );
+
+  TmwPasCodeInfo = (
+    ciNone,           //: @BUG heresy  !
+    ciAccessSpecifier,
+    ciAdditiveOperator,
+    ciArrayConstant,
+    ciArrayType,
+    ciAsmStatement,
+    ciBlock,
+    ciCaseLabel,
+    ciCaseSelector,
+    ciCaseStatement,
+    ciCharString,
+    ciClassClass,           //DR 2001-07-16
+    ciClassField,
+    ciClassForward,
+    ciClassFunctionHeading,
+    ciClassHeritage,
+    ciClassMemberList,
+    ciClassMethodDirective,
+    ciClassMethodHeading,
+    ciClassMethodOrProperty,
+    ciClassMethodResolution,
+    ciClassProcedureHeading,
+    ciClassProperty,
+    ciClassReferenceType,
+    ciClassType,
+    ciClassTypeEnd,			// DR 2001-07-31
+    ciClassVisibility,
+    ciCompoundStatement,
+	ciConstantColon,
+    ciConstantDeclaration,
+    ciConstantEqual,
+    ciConstantExpression,
+    ciConstantName,
+    ciConstantValue,
+    ciConstantValueTyped,
+    ciConstParameter,
+    ciConstructorHeading,
+    ciConstructorName,
+    ciConstSection,
+    ciContainsClause,
+    ciContainsExpression,
+    ciContainsIdentifier,
+    ciContainsStatement,
+    ciDeclarationSection,
+    ciDesignator,
+    ciDestructorHeading,
+    ciDestructorName,
+    ciDirective16Bit,
+    ciDirectiveBinding,
+	ciDirectiveCalling,
+	ciDirectiveDeprecated,	// DR 2001-10-20
+	ciDirectiveLibrary,		// DR 2001-10-20
+	ciDirectiveLocal,		// DR 2001-11-14
+	ciDirectivePlatform,	// DR 2001-10-20
+	ciDirectiveVarargs,		// DR 2001-11-14	
+	ciDispIDSpecifier,		// DR 2001-07-26
+    ciDispInterfaceForward,
+    ciEmptyStatement,
+	ciEnumeratedType,
+	ciEnumeratedTypeItem,	// DR 2001-10-29
+    ciExceptBlock,
+    ciExceptionBlockElseBranch,
+    ciExceptionClassTypeIdentifier,
+    ciExceptionHandler,
+    ciExceptionHandlerList,
+    ciExceptionIdentifier,
+    ciExceptionVariable,
+    ciExpliciteType,
+    ciExportedHeading,
+    ciExportsClause,
+    ciExportsElement,
+    ciExpression,
+    ciExpressionList,
+    ciExternalDirective,
+    ciExternalDirectiveThree,
+    ciExternalDirectiveTwo,
+    ciFactor,
+    ciFieldDeclaration,
+    ciFieldList,
+    ciFileType,
+    ciFormalParameterList,
+    ciFormalParameterSection,
+    ciForStatement,
+	ciForwardDeclaration, // DR 2001-07-23
+    ciFunctionHeading,
+    ciFunctionMethodDeclaration,
+    ciFunctionMethodName,
+	ciFunctionProcedureBlock,
+	ciFunctionProcedureName,
+	ciHandlePtCompDirect,   //XM 20001125
+	ciHandlePtDefineDirect, //XM 20001125
+	ciHandlePtElseDirect,   //XM 20001125
+	ciHandlePtIfDefDirect,  //XM 20001125
+	ciHandlePtEndIfDirect,  //XM 20001125
+	ciHandlePtIfNDefDirect, //XM 20001125
+	ciHandlePtIfOptDirect,  //XM 20001125
+	ciHandlePtIncludeDirect,//XM 20001125
+	ciHandlePtResourceDirect,//XM 20001125
+	ciHandlePtUndefDirect, //XM 20001125
+	ciIdentifier,
+    ciIdentifierList,
+    ciIfStatement,
+    ciImplementationSection,
+    ciIncludeFile,
+    ciIndexSpecifier,	// DR 2001-07-26
+    ciInheritedStatement,
+    ciInitializationSection,
+    ciInlineStatement,
+    ciInterfaceDeclaration,
+    ciInterfaceForward,
+    ciInterfaceGUID,
+    ciInterfaceHeritage,
+    ciInterfaceMemberList,
+    ciInterfaceSection,
+    ciInterfaceType,
+    ciLabelDeclarationSection,
+    ciLabeledStatement,
+	ciLabelId,
+	ciLibraryFile,
+    ciMainUsedUnitExpression,
+    ciMainUsedUnitName,
+    ciMainUsedUnitStatement,
+    ciMainUsesClause,
+    ciMultiplicativeOperator,
+    ciNewFormalParameterType,
+    ciNumber,
+    ciNextToken, //XM 20002512
+    ciObjectConstructorHeading,
+    ciObjectDestructorHeading,
+    ciObjectField,
+    ciObjectForward,
+    ciObjectFunctionHeading,
+    ciObjectHeritage,
+    ciObjectMemberList,
+    ciObjectMethodDirective,
+    ciObjectMethodHeading,
+    ciObjectNameOfMethod,
+    ciObjectProcedureHeading,
+    ciObjectProperty,          	// DR 2001-08-07
+    ciObjectPropertySpecifiers, // DR 2001-08-07
+    ciObjectType,
+    ciObjectTypeEnd,			// DR 2001-08-07
+    ciObjectVisibility,
+    ciOldFormalParameterType,
+    ciOrdinalIdentifier,
+    ciOrdinalType,
+    ciOutParameter,
+	ciPackageFile,
+	ciParameterFormal,
+    ciParameterName,
+    ciParameterNameList,
+    ciParseFile,
+    ciPointerType,
+    ciProceduralDirective,
+    ciProceduralType,
+    ciProcedureDeclarationSection,
+    ciProcedureHeading,
+    ciProcedureMethodDeclaration,
+    ciProcedureMethodName,
+    ciProgramBlock,
+    ciProgramFile,
+    ciPropertyDefault,		// DR 2001-07-16
+    ciPropertyInterface,
+    ciPropertyName,
+    ciPropertyParameterConst,
+    ciPropertyParameterList,
+    ciPropertySpecifiers,
+    ciQualifiedIdentifier,
+    ciQualifiedIdentifierList,
+    ciRaiseStatement,
+    ciReadAccessIdentifier,
+    ciRealIdentifier,
+    ciRealType,
+    ciRecordConstant,
+    ciRecordFieldConstant,
+    ciRecordType,
+    ciRecordVariant,
+	ciRelativeOperator,
+    ciRepeatStatement,
+    ciRequiresClause,
+    ciRequiresIdentifier,
+    ciResolutionInterfaceName,
+    ciResourceDeclaration,
+    ciReturnType,
+    ciSEMICOLON, //XM 20002512
+    ciSetConstructor,
+    ciSetElement,
+    ciSetType,
+    ciSimpleExpression,
+    ciSimpleStatement,
+    ciSimpleType,
+    ciSkipAnsiComment,
+    ciSkipBorComment,
+    ciSkipSlashesComment,
+    ciSkipSpace, //XM 20002511
+    ciSkipCRLFco, //XM 20002511
+    ciSkipCRLF, //XM 20002511
+    ciStatement,
+    ciStatementList,
+    ciStorageExpression,
+    ciStorageIdentifier,
+    ciStorageDefault,
+    ciStorageNoDefault,
+    ciStorageSpecifier,
+    ciStorageStored,
+    ciStringIdentifier,
+	ciStringStatement,
+    ciStringType,
+    ciStructuredType,
+    ciSubrangeType,
+    ciTagField,
+    ciTagFieldName,
+    ciTagFieldTypeName,
+    ciTerm,
+    ciTryStatement,
+    ciTypedConstant,
+    ciTypeDeclaration,
+    ciTypeId,
+    ciTypeKind,
+    ciTypeName,
+    ciTypeSection,
+    ciUnitFile,
+    ciUnitId,
+    ciUsedUnitName,
+    ciUsedUnitsList,
+    ciUsesClause,
+    ciVarAbsolute,
+    ciVarEqual,
+    ciVarDeclaration,
+    ciVariable,
+    ciVariableList,
+    ciVariableReference,
+    ciVariableTwo,
+    ciVariantIdentifier,
+    ciVariantSection,
+	ciVarParameter,
+    ciVarSection,
+    ciVisibilityAutomated,
+    ciVisibilityPrivate,
+    ciVisibilityProtected,
+    ciVisibilityPublic,
+    ciVisibilityPublished,
+    ciVisibilityUnknown,
+    ciWhileStatement,
+    ciWithStatement,
+    ciWriteAccessIdentifier
+    );
+
+function ParserErrorName(Value: TmwParseError): string;
+
+implementation
+
+function ParserErrorName(Value: TmwParseError): string;
+begin
+  result := GetEnumName(TypeInfo(TmwParseError), Integer(Value));
+end;
+
+end.
+