Fortran2003 でのオブジェクト指向

Intel Fortran ではまだ Fortran2003 が完全実装されていないので、オブジェクト指向がらみの機能は、未実装だったりコンパイラのバグが多いのですが、一応挑戦？

インスタンスの生成は、ALLOCATEでやるのかな？　CLASS を使った包括的な構造体の使い方がイマイチよく分かりません。

スカラーのサブルーチン付き構造体をアロケートすると実行エラーが起きるので、要素１個の配列にしてます。 別の条件の時の勘違いでこの場合は大丈夫でした。

実行結果

ソースコード

MODULE m_locate
USE ifwinty
USE kernel32
IMPLICIT NONE
CONTAINS
!
  SUBROUTINE locate(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 :: t_shape
    REAL :: x = 0.0 , y = 0.0
  END TYPE t_shape

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


  SUBROUTINE prc(b)
!   CLASS (t_circle), INTENT(IN OUT) :: b(:)
    TYPE (t_circle), INTENT(IN OUT) :: b(:)
    INTEGER :: i
    DO i = 1, SIZE(b)
      CALL b(i)%draw() 
    END DO

    RETURN
  END SUBROUTINE prc

  SUBROUTINE prt(a)
    CLASS (t_shape), INTENT(IN) :: a
    INTEGER :: i = 1
    SELECT TYPE (a)
      TYPE IS (t_circle)
        CALL a%draw()
      TYPE IS (t_rectangle)
        CALL a%draw()
      CLASS IS (t_shape)
        PRINT *, 'shape!'
      CLASS DEFAULT   
        PRINT *, 'CLASS DEFAULT'
    END SELECT
    RETURN
  END SUBROUTINE prt
  
END MODULE m_test

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

PROGRAM test
USE m_test
IMPLICIT NONE
  TYPE (t_circle   ), ALLOCATABLE :: c(:)
  TYPE (t_rectangle), ALLOCATABLE :: r1, r2
  
  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) )
 
  CALL prc(c)
  CALL prt(r1)
  CALL prt(r2)  
 
  CALL pr(0, 23, '')
  STOP
END PROGRAM test