M2compiler-V3/compiler/tests/t_virtual.mod

MODULE TVirtual;
(* Virtual dispatch (vtables): a base-class pointer holding a derived
   object calls the derived method. Exit 3. *)
VAR ExitCode : INTEGER;
TYPE
  CLASS Shape;
    VIRTUAL PROCEDURE Draw() : INTEGER;
  END Shape;
  CLASS Circle (Shape);
    VIRTUAL PROCEDURE Draw() : INTEGER;
  END Circle;
  CLASS Square (Shape);
    VIRTUAL PROCEDURE Draw() : INTEGER;
  END Square;
CLASS IMPLEMENTATION Shape;
  PROCEDURE Draw() : INTEGER; BEGIN RETURN 1 END Draw;
END Shape;
CLASS IMPLEMENTATION Circle;
  PROCEDURE Draw() : INTEGER; BEGIN RETURN 2 END Draw;
END Circle;
CLASS IMPLEMENTATION Square;
  PROCEDURE Draw() : INTEGER; BEGIN RETURN 3 END Draw;
END Square;

VAR b : POINTER TO Shape;
VAR c : POINTER TO Circle;
VAR q : POINTER TO Square;
BEGIN
  ExitCode := 0;
  NEW(c); b := c;                 (* subtype pointer assignment *)
  IF b^.Draw() = 2 THEN ExitCode := ExitCode + 1 END;
  NEW(q); b := q;
  IF b^.Draw() = 3 THEN ExitCode := ExitCode + 2 END
END TVirtual.