module exe testing_runner;

@unitTestMode on;

import testing_unit;

var
  GHits: int32 = 0;
  GText: string = "a";

initialize
begin
  println("main init");
end;

finalize
begin
  println("main final");
end;

begin
  println("the body does not run in test mode");
end.

test "asserts that hold"
var
  LP: ptr to int32;
  LW: uint32;
  LI: int32;
begin
  LP := address of GHits;
  LW := 7;
  LI := 2;
  testAssertNotNil(LP);
  testAssertEqualInt(16, testing_unit.Square(4));
  testAssertEqualInt(7, LW);
  testAssertEqualFloat(2.0, LI);
  testAssertEqualFloat(0.3, 0.1 + 0.2);
  testAssertEqualStr("ab", GText + "b");
end;

test "asserts that fail"
begin
  testAssertEqualInt(10, testing_unit.Square(3));
  testFail("still runs after a failure");
end;

test "a raise ends the test"
begin
  raisecode(7, "stop");
  testFail("never reached");
end;

test "a fault ends the test"
var
  LQ: ptr to int32;
begin
  LQ := nil;
  LQ^ := 1;
  testFail("never reached");
end;

test "returns early"
begin
  GHits := GHits + 1;
  return;
  testFail("never reached");
end;

module exe objects_owners;

type
  TNode = object
    Name: int32;
    init(const AN: int32);
    begin
      self.Name := AN;
      println("init {}", self.Name);
    end;
    done;
    begin
      println("done {}", self.Name);
    end;
  end;
  TBase = object
    virtual method Speak();
    begin
      println("base");
    end;
    done;
    begin
      println("done base");
    end;
  end;
  TKid = object(TBase)
    override method Speak();
    begin
      println("kid");
    end;
    done;
    begin
      println("done kid");
    end;
  end;

routine Make(const AN: int32): own TNode;
begin
  return own TNode(AN);
end;

routine Owns();
var
  LO: own TNode;
  LB: own TBase;
begin
  LO := Make(1);
  LO.Name := 11;
  println("own {}", LO.Name);
  // An own of a polymorphic root frees the whole object
  LB := own TKid;
  LB.Speak();
end;

routine Shares();
var
  LA: ref TNode;
  LB: ref TNode;
  LW: weak TNode;
begin
  LA := ref TNode(2);
  LB := LA;
  LW := LA;
  println("alive {}", alive(LW));
  LA := nil;
  println("still {}", lock(LW).Name);
  // The last ref goes: the object ends
  LB := nil;
  println("alive {}", alive(LW));
end;

routine NilAccess();
var
  LO: own TNode;
begin
  guard
    println("{}", LO.Name);
  except
    println("nil {}", exccode());
  end;
end;

begin
  Owns();
  Shares();
  NilAccess();
end.

module exe runtime_guards;

#include <stdexcept>

static void runtime_guards_std() {
  throw std::runtime_error("bad thing");
}

static void runtime_guards_int() {
  throw 42;
}

type
  TDigits = set of 0..9;

routine Deep(AN: int32): int32;
var
  LBuf: array[0..1023] of int64;
begin
  if AN = 0 then
    return 0;
  end;
  LBuf[0] := AN;
  return Deep(AN - 1) + int32(LBuf[0] mod 2);
end;

routine Show(const AWhat: string; ACode: int32; const AMsg: string);
begin
  println("{}: {} {}", AWhat, ACode, AMsg);
end;

var
  LP: ptr to int32;
  LZ: int32;
  LLow: int32;
  LN: int32;
  LK: int32;
  LS: TDigits;
  LF: float64;

begin
  LP := nil;
  LZ := 0;
  LLow := -2147483647 - 1;
  LK := 20;

  // a write through nil
  guard
    LP^ := 1;
  except
    Show("nil write", exccode(), excmsg());
  end;

  // integer division by zero
  guard
    LN := LLow div LZ;
  except
    Show("div 0", exccode(), excmsg());
  end;

  guard
    LN := LLow mod LZ;
  except
    Show("mod 0", exccode(), excmsg());
  end;

  // the lowest int32 divided by -1 overflows
  LN := -1;
  guard
    LN := LLow div LN;
  except
    Show("low div -1", exccode(), excmsg());
  end;

  LN := -1;
  guard
    LN := LLow mod LN;
  except
    Show("low mod -1", exccode(), excmsg());
  end;

  // a stack overflow, caught twice
  guard
    LN := Deep(1000000);
  except
    Show("deep", exccode(), excmsg());
  end;

  guard
    LN := Deep(1000000);
  except
    Show("deep again", exccode(), excmsg());
  end;

  // C++ exceptions thrown by the mixed C++ above
  guard
    runtime_guards_std();
  except
    Show("c++ std", exccode(), excmsg());
  end;

  guard
    runtime_guards_int();
  except
    Show("c++ int", exccode(), excmsg());
  end;

  // a set element outside the set type's range
  guard
    LS := [LK];
  except
    Show("set", exccode(), excmsg());
  end;

  // raises of your own
  guard
    raise("plain");
  except
    Show("raise", exccode(), excmsg());
  end;

  guard
    raisecode(0, "zero");
  except
    Show("raisecode 0", exccode(), excmsg());
  end;

  guard
    raisecode(-5, "neg");
  except
    Show("raisecode -5", exccode(), excmsg());
  end;

  // a float division by zero raises nothing
  LF := 1.0;
  LF := LF / 0.0;
  println("float / 0.0: {}", LF);

  // the program went on: a fault is caught again
  guard
    LP^ := 2;
  except
    Show("nil again", exccode(), excmsg());
  end;
end.

module exe objects_cpp;

struct CShape {
  virtual ~CShape() = default;
  virtual int area() {
    return 0;
  }
  virtual int corners() const {
    return 0;
  }
  int sides = 0;
};

int cpp_area(CShape& s) {
  return s.area();
}

int cpp_corners(const CShape& s) {
  return s.corners();
}

type
  TSquare = object(CShape)
    S: int32;
    init(const AS: int32);
    begin
      self.S := AS;
      // sides is the C++ base's member
      self.sides := 4;
    end;
    override method area(): int32;
    begin
      return self.S * self.S;
    end;
    override const method corners(): int32;
    begin
      return self.sides;
    end;
  end;
  TRuler = object
    Len: int32;
    // A const method calls only const methods through self
    const method Size(): int32;
    begin
      return self.Twice();
    end;
    const method Twice(): int32;
    begin
      return self.Len * 2;
    end;
  end;

routine Measure(const AR: TRuler): int32;
begin
  return AR.Size();
end;

var
  LSq: TSquare(3);
  LR: TRuler;
begin
  println("{}", cpp_area(LSq));
  println("{} {}", LSq.sides, LSq.S);
  println("{}", cpp_corners(LSq));
  LR.Len := 6;
  println("{}", Measure(LR));
end.

module exe types_records;

type
  TBase = record
    A: int32;
  end;
  // An extension holds every field of its chain
  TExt = record(TBase)
    B: int32;
  end;
  TPk = record packed
    X: int8;
    Y: int32;
  end;
  TBits = record
    S: int32 : 3;
    F: bool : 1;
  end;

routine ShowBase(const AB: TBase);
begin
  println("base {}", AB.A);
end;

var
  LE: TExt;
  LZ: TExt;
  LP: ptr to TBase;
  LB: TBits;

begin
  println("zero {} {}", LZ.A, LZ.B);
  // A record literal names the inherited fields too
  LE := TExt(A: 1, B: 2);
  println("literal {} {} size {}", LE.A, LE.B, size(TExt));
  ShowBase(LE);
  LP := address of LE;
  println("through base {}", LP^.A);
  println("packed {}", size(TPk));
  LB.S := -4;
  LB.F := true;
  println("bits {} {}", LB.S, LB.F);
end.

module exe statements_guard_flow;

routine Find(): int32;
begin
  guard
    return 7;
  finally
    println("return finally");
  end;
end;

routine Handle(): int32;
begin
  guard
    raisecode(9, "nine");
  except
    print("except {}", exccode());
    return -1;
  finally
    println(" finally");
  end;
  return 0;
end;

var
  LI: int32;

begin
  for LI := 1 to 5 do
    guard
      if LI = 2 then
        print("skip {}", LI);
        skip;
      end;
      if LI = 3 then
        print("leave {}", LI);
        leave;
      end;
      print("pass {}", LI);
    finally
      println(" finally");
    end;
  end;
  println("loop done");
  println("found {}", Find());
  println("handled {}", Handle());
end.