Exemple de module (générique) tiré de l'ouvrage
MODULE PILE_GENERIC
TYPE ELEMENT
! Ici, déclaration de la structure des ELEMENTs empilés.
END TYPE
END MODULE
!****************************************************************
!* Gestion de la memoire pour l'allocation et la liberation *
!* de maillons (structure lineaire chainee monodirect.) *
!****************************************************************
MODULE PILE_ALLOCATION
USE PILE_GENERIC,ONLY: ELEMENT
TYPE MAILLON
TYPE(ELEMENT) :: valeur
TYPE(MAILLON),POINTER:: suivant
END TYPE
TYPE(MAILLON),POINTER,PRIVATE,SAVE:: L_LIBRE !pile des maillons liberes.
PRIVATE:: TEST_INIT
CONTAINS
SUBROUTINE TEST_INIT
LOGICAL:: PRIMAP = .TRUE.
IF (PRIMAP) THEN
NULLIFY (L_LIBRE) ! initialisation Liste Libre.
PRIMAP = .FALSE.
ENDIF
END SUBROUTINE
! Fournit 1 maillon physique,
! et renvoie l'adresse de ce maillon.
! Les parametres donnent le contenu du maillon cree.
FUNCTION M_ALLOC (VAL,ADR)
TYPE(MAILLON),POINTER :: M_ALLOC
TYPE(ELEMENT),INTENT(IN) :: VAL
TYPE(MAILLON),POINTER,OPTIONAL:: ADR
CALL TEST_INIT
IF (ASSOCIATED(L_LIBRE)) THEN
M_ALLOC => L_LIBRE ! prelevement sur liste libre.
L_LIBRE => L_LIBRE%SUIVANT ! maj @ liste libre.
ELSE
ALLOCATE (M_ALLOC)
ENDIF
M_ALLOC%VALEUR = VAL ! remplissage nouveau maillon.
IF(PRESENT(ADR))THEN
M_ALLOC%SUIVANT => ADR
ELSE
NULLIFY (M_ALLOC%SUIVANT)
ENDIF
END FUNCTION M_ALLOC
! Ramasse-miettes.
! Si FIN est present, recupere 1 liste lineaire fournie par ses
! adresses de TETE et de FIN;
! sinon, recupere 1 maillon donne par son adresse TETE.
! Au retour, les pointeurs presents sont mis a NULL.
! La proc. tient compte des cas ou la liste est vide.
SUBROUTINE M_FREE (TETE,FIN)
TYPE(MAILLON),POINTER :: TETE
TYPE(MAILLON),POINTER,OPTIONAL:: FIN
TYPE(MAILLON),POINTER:: TEMP
IF (ASSOCIATED (TETE)) THEN
CALL TEST_INIT
TEMP => TETE ! liste ou maillon isole.
IF (PRESENT (FIN)) THEN
IF (ASSOCIATED(FIN)) THEN
TEMP => FIN
NULLIFY (FIN)
ENDIF
ENDIF
TEMP%SUIVANT => L_LIBRE ! empiler toute la liste s/LL
L_LIBRE => TETE ! maj de la liste libre.
NULLIFY (TETE) ! par securite...
ENDIF
END SUBROUTINE M_FREE
END MODULE PILE_ALLOCATION
!*******************************************************************
!* S T R U C T U R E D E P I L E N O N B O R N E E *
!*******************************************************************
MODULE PILES_ILLIMITEES
USE PILE_ALLOCATION ! (dont parm. de genericite)
USE FORTRAN_INITIALIZATION
USE FORTRAN_EXCEPTIONS ! cf. Annexe 4.
IMPLICIT NONE
PRIVATE
TYPE PILE; PRIVATE
TYPE(MAILLON),POINTER:: SOMMET
TYPE(T_INIT) :: INIT
END TYPE
! *** Toute PILE est initialement vide. ***
INTERFACE ASSIGNMENT(=) ! affectation prohibee.
MODULE PROCEDURE SETQ ! (recepteur inchange).
END INTERFACE
INTEGER,PARAMETER,PUBLIC:: PILE_VIDE = 3 !exception.
PUBLIC:: PILE, ELEMENT, &
P_RAZ, EMPILER, DEPILER, SOMMET, P_EST_VIDE, &
ASSIGNMENT(=) ! exporte la version locale.
CONTAINS
! SUBROUTINEs generales (privees):
SUBROUTINE TEST_CREATE (P)
TYPE(PILE),INTENT(INOUT):: P
IF (.NOT.IS_INIT(P%INIT)) THEN
CALL INITIALIZE(P%INIT)
NULLIFY (P%SOMMET)
ENDIF
END SUBROUTINE
SUBROUTINE EXCEPTION_PV (P,IOSTAT) ! la pile P est vide...
TYPE(PILE),INTENT(IN) :: P
INTEGER,INTENT(OUT),OPTIONAL:: IOSTAT
CALL EXCEPTION_MESSAGE (P%INIT,IOSTAT, &
PILE_VIDE, "PILE VIDE")
END SUBROUTINE
! GENERATEURS
! ===========
! Ajout d'un nouvel element au sommet d'une pile:
SUBROUTINE EMPILER (P, ELT_IN)
TYPE(PILE),INTENT(INOUT):: P
TYPE(ELEMENT),INTENT(IN):: ELT_IN
CALL TEST_CREATE (P)
P%SOMMET => M_ALLOC (ELT_IN,P%SOMMET)
END SUBROUTINE
! Suppression de l'element au sommet de P,
! fourni via ELT_OUT si ce parametre est present.
! Renvoie (via IOSTAT) l'exception PILE_VIDE
! si P_EST_VIDE (P) lors de l'appel
! (le resultat eventuel Elt_Out reste alors indetermine).
SUBROUTINE DEPILER (P, ELT_OUT, IOSTAT)
TYPE(PILE),INTENT(INOUT) :: P
TYPE(ELEMENT),INTENT(OUT),OPTIONAL:: ELT_OUT
INTEGER,INTENT(OUT),OPTIONAL :: IOSTAT
TYPE(MAILLON),POINTER:: TEMP
CALL TEST_CREATE (P)
IF (P_EST_VIDE(P)) THEN
CALL EXCEPTION_PV (P,IOSTAT)
ELSE
TEMP => P%SOMMET
IF (PRESENT(ELT_OUT)) ELT_OUT = TEMP%VALEUR
IF (PRESENT(IOSTAT)) IOSTAT = 0
P%SOMMET => TEMP%SUIVANT
CALL M_FREE (TEMP)
ENDIF
END SUBROUTINE
! Purge la pile P.
! Postassertion de P_RAZ: P_EST_VIDE (p).
SUBROUTINE P_RAZ (P)
TYPE(PILE),INTENT(INOUT):: P
TYPE(MAILLON),POINTER :: TEMP,FIN
CALL TEST_CREATE (P)
TEMP => P%SOMMET; NULLIFY(FIN)
DO WHILE (ASSOCIATED(TEMP))
FIN => TEMP ! @ du dernier maillon visite.
TEMP => TEMP%SUIVANT
END DO
CALL M_FREE (P%SOMMET, FIN) ! recuperation liste.
END SUBROUTINE
! OBSERVATEUR & FONCTION D'ACCES
! ================================
! Consultation de l'element au sommet d'une pile.
! Renvoie (via IOSTAT) l'exception PILE_VIDE
! si P_EST_VIDE (P) lors de l'appel
! (la valeur de la fonction est alors indeterminee).
TYPE(ELEMENT) FUNCTION SOMMET (P, IOSTAT)
TYPE(PILE),INTENT(INOUT) :: P
INTEGER, INTENT(OUT),OPTIONAL:: IOSTAT
CALL TEST_CREATE (P)
IF (P_EST_VIDE(P)) THEN
CALL EXCEPTION_PV (P,IOSTAT)
ELSE
SOMMET = P%SOMMET%VALEUR
IF (PRESENT(IOSTAT)) IOSTAT = 0
ENDIF
END FUNCTION
! Test de l'etat de la pile P:
LOGICAL FUNCTION P_EST_VIDE (P)
TYPE(PILE),INTENT(INOUT):: P
CALL TEST_CREATE (P)
P_EST_VIDE = .NOT. ASSOCIATED (P%SOMMET)
END FUNCTION
SUBROUTINE SETQ (P_SOR, P_ENT) ! pour empecher l'affectation.
TYPE(PILE),INTENT(INOUT):: P_SOR
TYPE(PILE),INTENT(IN) :: P_ENT
CALL TEST_INIT (P_SOR%INIT)
CALL ASSIGNMENT_MESSAGE (P_SOR%INIT)
END SUBROUTINE
END MODULE PILES_ILLIMITEES