PRIVATE

昨日の奴に PUBLIC / PRIVATE のアクセス指定を掛けてみたけど、まだよく挙動がわかりません。

ソース・コード

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
    PRIVATE
    PUBLIC :: t_shape
 
    TYPE, ABSTRACT :: t_shape
      PRIVATE
     CONTAINS
      PROCEDURE (p_draw), DEFERRED, PUBLIC :: draw
    END TYPE t_shape
  
    ABSTRACT INTERFACE
      SUBROUTINE p_draw(this)
        IMPORT :: t_shape
        CLASS (t_shape), INTENT(IN) :: this
      END SUBROUTINE p_draw

      SUBROUTINE p_set(this)
        IMPORT :: t_shape
        CLASS (t_shape), INTENT(IN) :: this
      END SUBROUTINE p_set
    END INTERFACE

END MODULE m_shape

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

MODULE m_test
    USE m_shape
    USE m_locate
    IMPLICIT NONE
    PRIVATE
    PUBLIC :: t_shape, t_circle, t_rectangle

    TYPE, EXTENDS(t_shape) :: t_circle
      REAL, PRIVATE :: x = 0.0, y = 0.0
      REAL, PRIVATE :: r = 0.0
     CONTAINS
      PROCEDURE :: draw => draw_circle
      PROCEDURE :: set  => set_circle
    END TYPE t_circle

    TYPE, EXTENDS(t_shape) :: t_rectangle
      REAL, PRIVATE :: x  = 0.0, y  = 0.0
      REAL, PRIVATE :: dx = 0.0, dy = 0.0
     CONTAINS
      PROCEDURE :: draw => draw_rectangle
      PROCEDURE :: set  => set_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 set_circle(this, that)
      CLASS (t_circle), INTENT(OUT) :: this
      TYPE  (t_circle), INTENT(IN ) :: that
      this%x = that%x
      this%y = that%y
      this%r = that%r
      RETURN    
    END SUBROUTINE set_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 set_rectangle(this, that)
      CLASS (t_rectangle), INTENT(OUT) :: this
      TYPE  (t_rectangle), INTENT(IN ) :: that
      this%x  = that%x
      this%y  = that%y
      this%dx = that%dx
      this%dy = that%dy
      RETURN    
    END SUBROUTINE set_rectangle

END MODULE m_test

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

PROGRAM ooptest
    USE m_test
    USE m_locate
    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) )
    CALL c(1)%set( t_circle(10.0, 10.0,  6.0) )
    CALL c(2)%set( 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) )
    r1 = t_rectangle(20.0, 10.0, 35.0, 10.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