milancurcic
commented
4 years ago I like the idea. Can you show the prototype? How would this class and module be called?
Open rweed opened 4 years ago
milancurcic
commented
4 years ago I like the idea. Can you show the prototype? How would this class and module be called?
rweed
commented
4 years ago OK. the entire module (again sorry about the length) follows. Again, I implement this as a concrete and not an abstract class because an abstract class with deferred interfaces obligates the user to implement all of the methods in the extended class. If someone can suggest a better approach please let me know. I wrote this about 5 years ago when compilers where still gagging on some of the OO features so there might be a better way to do this. However, this works so I've not seen any need to change it. I can post a use case where I extend the user type into a point class to store coordinates of nodes in a FEM mesh and then use quickSort to sort the points based on distance from the origin
* userType.F90 **
! Copyright (C) 2015-2019 Richard Weed.
! All rights reserved.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code, in whole or in part, must retain the
! above copyright notice, this list of conditions and the following
! disclaimer.
! 2. Redistributions in binary form, in whole or in part, must reproduce the
! above copyright notice, this list of conditions and the following disclaimer
! in the documentation and/or other materials provided with the distribution.
! 3. The names of the contributors may not be used to endorse or promote from
! products derived from this software without specific prior written
! permission.
! 4. Redistributions of this software, in whole or in part, in any form,
! must be freely available and licensed under this original License. The
! U.S. Government may add additional restrictions to their modified and
! redistributed software as required by Law. However, these restrictions
! do not apply to the original software distribution.
! 5. Redistribution of this source code, including any modifications, may
! not be intentionally obfuscated.
! 6. Other code may make use of this software, in whole or in part, without
! restriction, provided that it does not apply any restriction to this
! software other than outlined above.
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS AND
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE), ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Module userClass
! Defines an base container class for creating user defined types to be
! used with generic ADT routines. It is intended that this base class
! be extended and should not be used directly. We implement this as a
! concrete class instead of an abstract one to allow users to override
! only the type bound procedures they will use in their applications. An
! abstract interface forces users to implement all of the procedures.
! Written by: Richard Weed, Ph.D.
! Missississippi State University
! Center for Advanced Vehicular Systems
! Version No. : 1
! Revision History : Initial version - December 2014
Implicit NONE
! Define a User class that can be used to create other
! classes. Its primary use is in createing ADT lists
! but can also be used in any case where unlimited
! polymorphic dummy arguments are used to create
! a generic routine that mixes both intrinsic and
! user defined data types.
Type :: User_t
Contains
Procedure :: isUserEQ
Procedure :: isUserGT
Procedure :: isUserLT
Procedure :: isUserGTE
Procedure :: isUserLTE
Procedure :: isUserNE
Procedure :: printUserValue
Procedure :: assignValue
Generic :: OPERATOR(==) => isUserEQ
Generic :: OPERATOR(/=) => isUserNE
Generic :: OPERATOR(<) => isUserLT
Generic :: OPERATOR(>) => isUserGT
Generic :: OPERATOR(<=) => isUserLTE
Generic :: OPERATOR(>=) => isUserGTE
Generic :: ASSIGNMENT(=) => assignValue
Generic :: printValue => printUserValue
End Type
Type :: UserPtr_t
Class(User_t), Pointer :: userptr
End Type
CONTAINS
Logical Function isUserEQ(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserEQ = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserEQ not overridden'
End Select
End Select
End Function isUserEQ
Logical Function isUserGT(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserGT = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserGT not overridden'
End Select
End Select
End Function isUserGT
Logical Function isUserLT(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserLT = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserLT not overridden'
End Select
End Select
End Function isUserLT
Logical Function isUserGTE(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserGTE = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserGTE not overridden'
End Select
End Select
End Function isUserGTE
Logical Function isUserLTE(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserLTE = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserLTE not overridden'
End Select
End Select
End Function isUserLTE
Logical Function isUserNE(this, value)
Implicit NONE
Class(User_t), Intent(IN) :: this
Class(*), Intent(IN) :: value
isUserNE = .FALSE.
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>value)
Class Is(User_t)
Print *,' ** User_t isUserNE not overridden'
End Select
End Select
End Function isUserNE
Subroutine printUserValue(this, iunit)
Implicit NONE
Class(User_t), Intent(IN), TARGET :: this
Integer, Intent(IN), OPTIONAL :: iunit
Select Type(r=>this)
Class Is(User_t)
If (PRESENT(iunit)) Then
Print *,' ** User_t printUserValue not overridden for iunit ', iunit
Else
Print *,' ** User_t printUserValue not overridden '
EndIf
End Select
End Subroutine printUserValue
Subroutine assignValue(this, that)
Implicit NONE
Class(User_t), Intent(INOUT) :: this
Class(User_t), Intent(IN) :: that
Select Type(r=>this)
Class Is(User_t)
Select Type(p=>that)
Class Is(User_t)
Print *,' ** User_t assignValue not overridden'
End Select
End Select
End Subroutine assignValue
End Module userClass
I implement a user base class to support some of the Abstract Data Types (lists etc) and sorting codes I've implemented. It contains no data but defines dummy procedures for things I need to do to support sorting , generic lists etc. mainly relational operators (> < >= <= == assighment etc) and a print method. I implement this as a concrete (non-abstract) class to avoid having to overide all the methods as would be required with an abstract class with deferred abstract interfaces for the procedures since I might not need all of the procedures defined in the concrete class in the extended class. I think we will need something similar to this (or maybe a God or World class ala java that all classes are derived from) to support user defined types.