Theia-Modula-2/grammars/Blaise/tests/deep.pas

program Deep;
{ Deep Blair Pascal surface test: must be accepted by the blaise oracle
  AND by the Blaise validator pilot. }

const
  MaxItems = 100;
  Neg = -5;
  Pi = 3.14159;
  Bits = 1 or 2 xor 4;
  Sh = 1 shl 3 + 16 shr 2;
  Mask = Bits and $FF;
  Greeting = 'Hello, ' + 'world';
  Names: array[0..1] of String = ('Sunny', 'Cloudy');
  M: array[0..1, 0..2] of Integer = ((1, 2, 3), (4, 5, 6));

type
  TColor = (Red, Green, Blue);
  TSub = Red..Blue;
  TByte = 0..255;
  TNeg = -10..10;
  TArr = array[0..9] of Integer;
  TMatrix = array[0..1, 0..2] of Integer;
  TByColor = array[TColor] of Integer;
  TByBool = array[Boolean] of Integer;
  TDyn = array of Integer;
  TSet = set of TColor;
  TByteSet = set of Byte;
  TRangeSet = set of 0..255;
  PInt = ^Integer;
  PPInt = ^PInt;
  TPoint = record
    X, Y: Integer;
    function Sum: Integer;
  end;
  TPacked = packed record
    B: Byte;
    I: Integer;
  end;
  TLogger = class(TObject)
  private
    FName: String;
    [Weak] FParent: TLogger;
  public
    constructor Create(AName: String); overload;
    destructor Destroy; override;
    procedure Log(Msg: String);
    function Level: Integer;
    function GetItem(Index: Integer): Integer;
    procedure SetItem(Index: Integer; Value: Integer);
    static var Count: Integer;
    property Name: String read FName write FName;
    property Items[Index: Integer]: Integer read GetItem write SetItem; default;
  end;
  TBox = class
  public
    function Get<T>(X: T): Integer;
  end;
  IShape = interface
    function Area: Integer;
    function GetSize: Integer;
    property Size: Integer read GetSize;
  end;
  EApp = class
  end;
  INamed = interface(IShape)
    function Title: String;
  end;
  TProc = reference to procedure(Value: Integer);
  TFunc = reference to function(A, B: Integer): Integer;
  TSingle = reference to function(N: Integer): Integer;
  TMyMeth = procedure of object;

  TGetInt = function: Integer;

const
  Primary = [Red, Green];

var
  i, j: Integer;
  b: Boolean;
  r: Integer;
  s: TSet;
  a: TArr;
  mat: TMatrix;
  p: PInt;
  logger: TLogger;
  box: TBox;
  shape: IShape;
  callback: TFunc;
  oneparam: TSingle;
  counter: Integer = 0;

threadvar
  TLS: Integer;

function TPoint.Sum: Integer;
begin
  Result := X + Y
end;

constructor TLogger.Create(AName: String);
begin
  inherited Create();
  FName := AName
end;

destructor TLogger.Destroy;
begin
  inherited Destroy()
end;

procedure TLogger.Log(Msg: String);
var
  Local: Integer;
begin
  WriteLn(Msg);
  Local := Local + 1
end;

function TLogger.Level: Integer;
begin
  Result := TLogger.Count
end;

function TLogger.GetItem(Index: Integer): Integer;
begin
  Result := Index
end;

procedure TLogger.SetItem(Index: Integer; Value: Integer);
begin
end;

function Add(const A, B: Integer): Integer; overload;
begin
  Result := A + B
end;

function Add(const A: String; const B: String): String; overload;
begin
  Result := A + B
end;

procedure Fill(var A: TArr; Value: Integer = 0);
var
  k: Integer;
begin
  for k := 0 to 9 do
    A[k] := Value
end;

procedure Consume(out X: Integer);
begin
  X := 42
end;

function Find(Needle: Integer; const Hay: TArr): Integer;
var
  k: Integer;
begin
  Result := -1;
  for k := 0 to 9 do
    if Hay[k] = Needle then
    begin
      Result := k;
      Break
    end;
  if Result = -1 then
    raise
end;

begin
  i := $FF + &77 + %101 + 1_000;
  r := 0;
  b := (i = 1) and (j <> 2) or not (i < j);
  b := (i = 1) xor True;
  i := 1 shl 2 + 8 shr 1;
  b := Blue in s;
  s := [Red, Green];
  s := [];
  a[0] := 1;
  mat[0, 1] := 2;
  logger := TLogger.Create('x');
  logger.Log('hi');
  i := logger.Level();
  i := TLogger.Count;
  logger.FName := 'y';
  p := nil;
  i := Low(a);
  i := High(a);
  callback := (A, B) -> A + B;
  i := callback(1, 2);
  oneparam := N -> N * 2;
  case i of
    1: Write(1);
    2, 3: Write(2);
    4..6: Write(3)
  else
    Write(9)
  end;
  while i < 10 do
    i := i + 1;
  repeat
    i := i - 1
  until i <= 0;
  for i in a do
    j := i;
  try
    i := 1
  finally
    i := 2
  end;
  try
    i := 1
  except
    on E: EApp do
      i := 2
    else
      i := 3
  end;
  if b then
    i := 1
  else if b then
    i := 2
  else
    i := 3;
  Fill(a);
  Fill(a, 7);
  Consume(i);
  i := Add(1, 2);
  WriteLn('done')
end.