ポインタ

以前はコンパイラのバグで動かなかったポインタを用いたプログラム例。

ALLOCATE( r1(1), SOURCE = t_rectangle(20.0, 10.0, 35.0, 10.0) )

こういう記法ができるので、初期化・代入ルーチンを自分で書く必要がありません。リリース・ノートを見ると、多態型の場合まだバグがあるようですが。（まだ TYPE 内の PUBLIC/PRIVATE の挙動がよくわかりません。）

ABSTRACT TYPE で図形の基本の抽象型を用意しておいて、DRAW SUBROUTINE は後で個別の図形ごとに用意するとして、DEFFERED で宣言しておきます。この時の関数インターフェースは、共通の様式を ABSTRACT INTERFACE で宣言することになります。ABSTRACT TYPE 中に具体的な変数要素を入れていいのかよく分からないけれど、あってもよい気がするので入れておきました。具体的な図形は、この抽象型を拡張（継承）することで定義します。
こうして定義された拡張型の範型の実現たる変数（インスタンス）は、静的変数として宣言してもいいのですが、ここでは動的変数として ALLOCATABLE で宣言して ALLOCATE で確保してみます。こういう目的のために F2003 ではスカラー変数を ALLOCATABLE で宣言できるようになったものと思われます。上に示したように、初期化時に初期値を与えることもできます。
これらの図形オブジェクトは基本の型のポインターに結び付けられます。ところでポインターの配列を定義することはできないので、ポインターを要素に持つ型を新たに定義して、その新しい型の配列を作ることで代用します。こうすることで、いろいろな図形を一つの配列に収めることができ、たとえばひとつのループで次々と図形を描画することが可能になります。

実行結果

ソース・コード

MODULE m_locate ! Win32 API call 
    USE ifwinty
    USE kernel32
    IMPLICIT NONE
  CONTAINS
!
    SUBROUTINE locate(ix, iy) ! move cursor to (ix, iy)
      INTEGER, INTENT(IN) :: ix, iy
      INTEGER (HANDLE) :: hout
      INTEGER (BOOL)   :: bret
      TYPE (T_COORD) :: tpos
      hout = GetStdHandle(STD_OUTPUT_HANDLE)
      tpos = t_coord( INT(ix, SHORT), INT(iy, SHORT) )
      bret = SetConsoleCursorPosition( hout, tpos )
      RETURN
    END SUBROUTINE locate
!
    SUBROUTINE pr(ix, iy, text)
      INTEGER, INTENT(IN) :: ix, iy
      CHARACTER(*), INTENT(IN) :: text
      CALL locate(ix, iy)
      WRITE(*, '(a)') text
      RETURN
    END SUBROUTINE pr
!
END MODULE m_locate

!===================================================

MODULE m_shape
    IMPLICIT NONE
 
    TYPE, ABSTRACT :: t_shape
      REAL :: x = 0.0 , y = 0.0
     CONTAINS
      PROCEDURE (p_draw), DEFERRED :: draw
    END TYPE t_shape
  
    ABSTRACT INTERFACE
      SUBROUTINE p_draw(this)
        IMPORT :: t_shape
        CLASS (t_shape), INTENT(IN) :: this
      END SUBROUTINE p_draw
    END INTERFACE

END MODULE m_shape

!===================================================

MODULE m_test
    USE m_shape
    USE m_locate
    IMPLICIT NONE

    TYPE, EXTENDS(t_shape) :: t_circle
      REAL :: r = 0.0
     CONTAINS
      PROCEDURE :: draw => draw_circle
    END TYPE t_circle

    TYPE, EXTENDS(t_shape) :: t_rectangle
      REAL :: dx = 0.0, dy = 0.0
     CONTAINS
      PROCEDURE :: draw => draw_rectangle
    END TYPE t_rectangle

  CONTAINS
 
    SUBROUTINE draw_circle(this)
      CLASS (t_circle), INTENT(IN) :: this
      REAL, PARAMETER :: pi = 4.0 * ATAN(1.0)
      INTEGER :: i, ix, iy
      REAL :: rx, ry
      DO i = 1, 99
       ix = INT( this%x + this%r * COS(pi * REAL(i) / 50.0) )
       iy = INT( this%y + this%r * SIN(pi * REAL(i) / 50.0) )
       CALL pr(ix, iy, '*')
      END DO
      RETURN
    END SUBROUTINE draw_circle
 
    SUBROUTINE draw_rectangle(this)
      CLASS (t_rectangle), INTENT(IN) :: this
      INTEGER :: i, ix, iy
      REAL :: rx, ry
      DO i = 1, 100
       ix = INT( this%x + this%dx * REAL(i) / 100.0 )
       CALL pr(ix, INT( this%y          ), '*')
       CALL pr(ix, INT( this%y + this%dy), '*')
       iy = INT( this%y + this%dy * REAL(i) / 100.0 )
       CALL pr(INT(this%x          ), iy, '*')
       CALL pr(INT(this%x + this%dx), iy, '*')
      END DO
      RETURN
    END SUBROUTINE draw_rectangle

END MODULE m_test

!========================================

PROGRAM ooptest
    USE m_test
    IMPLICIT NONE
    TYPE :: arr_shape
     CLASS (t_shape), POINTER :: p
    END TYPE 
    TYPE (arr_shape) :: ap(10)
    TYPE (t_circle   ), ALLOCATABLE, TARGET :: c(:)
    TYPE (t_rectangle), ALLOCATABLE, TARGET :: r1, r2
    INTEGER :: i
 
    ALLOCATE( c(2) )
    c(1) = t_circle(10.0, 10.0,  6.0)
    c(2) = t_circle(40.0, 12.0, 10.0)
 
    ALLOCATE( r1, SOURCE = t_rectangle(20.0, 10.0, 35.0, 10.0) )
    ALLOCATE( r2, SOURCE = t_rectangle(60.0,  2.0, 15.0,  8.0) )
 
 
    ap(1)%p => c(1)
    ap(2)%p => c(2)
    ap(3)%p => r1
    ap(4)%p => r2
    DO i = 1, 4
     CALL ap(i)%p%draw()
    END DO
  
    CALL pr(0, 23, '') ! MOVE TO BOTTOM
    STOP
END PROGRAM ooptest