I get a run time error (crashes console) on both my Win64 Vista machine (IA-32) and WinXP machine on some code that compiles without warnings with gfortran.
Same code compiles and runs OK in g95 and IVF 11.0. My test case (below) is calling one of the get() generics from the iso_varying_string module. It reads a text file ok without the optional set= argument but crashes when that is included. gfortran: f951.exe dated 19/12/2008 [components] runtime=mingwrt-3.15.1-mingw32.tar.gz w32api=w32api-3.12-mingw32-dev.tar.gz binutils=binutils-2.17.50-20060824-1.tar.gz core=gcc-core-3.4.5-20060117-3.tar.gz gpp=gcc-g++-3.4.5-20060117-3.tar.gz g77= ada= java= objc= make=mingw32-make-3.81-20080326-2.tar.gz ========================================================================== ! ***************************************************************** ! * * ! * iso_varying_string.f90 * ! * * ! * Copyright (C) 2003 Rich Townsend <r...@star.ucl.ac.uk> * ! * * ! * This program is free software; you can redistribute it and/or * ! * modify it under the terms of the GNU Lesser General Public * ! * License as published by the Free Software Foundation; either * ! * version 2.1 of the License, or (at your option) any later * ! * version. * ! * * ! * This program is distributed in the hope that it will be * ! * useful, but WITHOUT ANY WARRANTY; without even the implied * ! * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR * ! * PURPOSE. See the GNU Lesser General Public License for more * ! * details. * ! * * ! * You should have received a copy of the GNU Lesser General * ! * Public License along with this program; if not, write to the * ! * Free Software Foundation, Inc., 59 Temple Place, Suite 330, * ! * Boston, MA 02111-1307 USA * ! * * ! ***************************************************************** ! ! Developer : Rich Townsend <r...@star.ucl.ac.uk> ! Synopsis : Definition of iso_varying_string module, conformant to ! the API specified in ISO/IEC 1539-2:2000 (varying-length ! strings for Fortran 95). ! Notes : This implementation of iso_varying_string is designed to avoid ! the possibility of memory leaks. To achieve this, it takes ! advantage of language extensions specified in ISO/IEC ! TR 15581 (enhanced data type facilities). Many vendors ! support these extensions, and they will form a core part ! of Fortran 2000. ! Version : 1.2 ! Thanks : Lawrie Schonfelder's iso_varying_string module provided me ! with much insight on how to go about writing this module, ! for which I am very grateful. Furthermore, Lawrie helped ! point out some subtle bugs in the module. module iso_varying_string ! No implicit typing implicit none ! Parameter definitions integer, parameter :: GET_BUFFER_LEN = 256 ! Type definitions type varying_string private character(LEN=1), dimension(:), allocatable :: chars end type varying_string ! Interface blocks interface assignment(=) module procedure op_assign_CH_VS module procedure op_assign_VS_CH end interface assignment(=) interface operator(//) module procedure op_concat_VS_VS module procedure op_concat_CH_VS module procedure op_concat_VS_CH end interface operator(//) interface operator(==) module procedure op_eq_VS_VS module procedure op_eq_CH_VS module procedure op_eq_VS_CH end interface operator(==) interface operator(/=) module procedure op_ne_VS_VS module procedure op_ne_CH_VS module procedure op_ne_VS_CH end interface operator (/=) interface operator(<) module procedure op_lt_VS_VS module procedure op_lt_CH_VS module procedure op_lt_VS_CH end interface operator (<) interface operator(<=) module procedure op_le_VS_VS module procedure op_le_CH_VS module procedure op_le_VS_CH end interface operator (<=) interface operator(>=) module procedure op_ge_VS_VS module procedure op_ge_CH_VS module procedure op_ge_VS_CH end interface operator (>=) interface operator(>) module procedure op_gt_VS_VS module procedure op_gt_CH_VS module procedure op_gt_VS_CH end interface operator (>) interface adjustl module procedure adjustl_ end interface adjustl interface adjustr module procedure adjustr_ end interface adjustr interface char module procedure char_auto module procedure char_fixed end interface char interface iachar module procedure iachar_ end interface iachar interface ichar module procedure ichar_ end interface ichar interface index module procedure index_VS_VS module procedure index_CH_VS module procedure index_VS_CH end interface index interface len module procedure len_ end interface len interface len_trim module procedure len_trim_ end interface len_trim interface lge module procedure lge_VS_VS module procedure lge_CH_VS module procedure lge_VS_CH end interface lge interface lgt module procedure lgt_VS_VS module procedure lgt_CH_VS module procedure lgt_VS_CH end interface lgt interface lle module procedure lle_VS_VS module procedure lle_CH_VS module procedure lle_VS_CH end interface lle interface llt module procedure llt_VS_VS module procedure llt_CH_VS module procedure llt_VS_CH end interface llt interface repeat module procedure repeat_ end interface repeat interface scan module procedure scan_VS_VS module procedure scan_CH_VS module procedure scan_VS_CH end interface scan interface trim module procedure trim_ end interface trim interface verify module procedure verify_VS_VS module procedure verify_CH_VS module procedure verify_VS_CH end interface verify interface var_str module procedure var_str_ end interface var_str interface get module procedure get_ module procedure get_unit module procedure get_set_VS module procedure get_set_CH module procedure get_unit_set_VS module procedure get_unit_set_CH end interface get interface put module procedure put_VS module procedure put_CH module procedure put_unit_VS module procedure put_unit_CH end interface put interface put_line module procedure put_line_VS module procedure put_line_CH module procedure put_line_unit_VS module procedure put_line_unit_CH end interface put_line interface extract module procedure extract_VS module procedure extract_CH end interface extract interface insert module procedure insert_VS_VS module procedure insert_CH_VS module procedure insert_VS_CH module procedure insert_CH_CH end interface insert interface remove module procedure remove_VS module procedure remove_CH end interface remove interface replace module procedure replace_VS_VS_auto module procedure replace_CH_VS_auto module procedure replace_VS_CH_auto module procedure replace_CH_CH_auto module procedure replace_VS_VS_fixed module procedure replace_CH_VS_fixed module procedure replace_VS_CH_fixed module procedure replace_CH_CH_fixed module procedure replace_VS_VS_VS_target module procedure replace_CH_VS_VS_target module procedure replace_VS_CH_VS_target module procedure replace_CH_CH_VS_target module procedure replace_VS_VS_CH_target module procedure replace_CH_VS_CH_target module procedure replace_VS_CH_CH_target module procedure replace_CH_CH_CH_target end interface interface split module procedure split_VS module procedure split_CH end interface split ! Access specifiers private public :: varying_string public :: assignment(=) public :: operator(//) public :: operator(==) public :: operator(/=) public :: operator(<) public :: operator(<=) public :: operator(>=) public :: operator(>) public :: adjustl public :: adjustr public :: char public :: iachar public :: ichar public :: index public :: len public :: len_trim public :: lge public :: lgt public :: lle public :: llt public :: repeat public :: scan public :: trim public :: verify public :: var_str public :: get public :: put public :: put_line public :: extract public :: insert public :: remove public :: replace public :: split ! Procedures contains !**** elemental subroutine op_assign_CH_VS (var, exp) character(LEN=*), intent(out) :: var type(varying_string), intent(in) :: exp ! Assign a varying string to a character string var = char(exp) ! Finish return end subroutine op_assign_CH_VS !**** elemental subroutine op_assign_VS_CH (var, exp) type(varying_string), intent(out) :: var character(LEN=*), intent(in) :: exp ! Assign a character string to a varying string var = var_str(exp) ! Finish return end subroutine op_assign_VS_CH !**** elemental function op_concat_VS_VS (string_a, string_b) result (concat_string) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b type(varying_string) :: concat_string integer :: len_string_a ! Concatenate two varying strings len_string_a = len(string_a) ALLOCATE(concat_string%chars(len_string_a+len(string_b))) concat_string%chars(:len_string_a) = string_a%chars concat_string%chars(len_string_a+1:) = string_b%chars ! Finish return end function op_concat_VS_VS !**** elemental function op_concat_CH_VS (string_a, string_b) result (concat_string) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b type(varying_string) :: concat_string ! Concatenate a character string and a varying ! string concat_string = op_concat_VS_VS(var_str(string_a), string_b) ! Finish return end function op_concat_CH_VS !**** elemental function op_concat_VS_CH (string_a, string_b) result (concat_string) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b type(varying_string) :: concat_string ! Concatenate a varying string and a character ! string concat_string = op_concat_VS_VS(string_a, var_str(string_b)) ! Finish return end function op_concat_VS_CH !**** elemental function op_eq_VS_VS (string_a, string_b) result (op_eq) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_eq ! Compare (==) two varying strings op_eq = char(string_a) == char(string_b) ! Finish return end function op_eq_VS_VS !**** elemental function op_eq_CH_VS (string_a, string_b) result (op_eq) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_eq ! Compare (==) a character string and a varying ! string op_eq = string_a == char(string_b) ! Finish return end function op_eq_CH_VS !**** elemental function op_eq_VS_CH (string_a, string_b) result (op_eq) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_eq ! Compare (==) a varying string and a character ! string op_eq = char(string_a) == string_b ! Finish return end function op_eq_VS_CH !**** elemental function op_ne_VS_VS (string_a, string_b) result (op_ne) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_ne ! Compare (/=) two varying strings op_ne = char(string_a) /= char(string_b) ! Finish return end function op_ne_VS_VS !**** elemental function op_ne_CH_VS (string_a, string_b) result (op_ne) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_ne ! Compare (/=) a character string and a varying ! string op_ne = string_a /= char(string_b) ! Finish return end function op_ne_CH_VS !**** elemental function op_ne_VS_CH (string_a, string_b) result (op_ne) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_ne ! Compare (/=) a varying string and a character ! string op_ne = char(string_a) /= string_b ! Finish return end function op_ne_VS_CH !**** elemental function op_lt_VS_VS (string_a, string_b) result (op_lt) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_lt ! Compare (<) two varying strings op_lt = char(string_a) < char(string_b) ! Finish return end function op_lt_VS_VS !**** elemental function op_lt_CH_VS (string_a, string_b) result (op_lt) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_lt ! Compare (<) a character string and a varying ! string op_lt = string_a < char(string_b) ! Finish return end function op_lt_CH_VS !**** elemental function op_lt_VS_CH (string_a, string_b) result (op_lt) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_lt ! Compare (<) a varying string and a character ! string op_lt = char(string_a) < string_b ! Finish return end function op_lt_VS_CH !**** elemental function op_le_VS_VS (string_a, string_b) result (op_le) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_le ! Compare (<=) two varying strings op_le = char(string_a) <= char(string_b) ! Finish return end function op_le_VS_VS !**** elemental function op_le_CH_VS (string_a, string_b) result (op_le) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_le ! Compare (<=) a character string and a varying ! string op_le = string_a <= char(string_b) ! Finish return end function op_le_CH_VS !**** elemental function op_le_VS_CH (string_a, string_b) result (op_le) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_le ! Compare (<=) a varying string and a character ! string op_le = char(string_a) <= string_b ! Finish return end function op_le_VS_CH !**** elemental function op_ge_VS_VS (string_a, string_b) result (op_ge) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_ge ! Compare (>=) two varying strings op_ge = char(string_a) >= char(string_b) ! Finish return end function op_ge_VS_VS !**** elemental function op_ge_CH_VS (string_a, string_b) result (op_ge) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_ge ! Compare (>=) a character string and a varying ! string op_ge = string_a >= char(string_b) ! Finish return end function op_ge_CH_VS !**** elemental function op_ge_VS_CH (string_a, string_b) result (op_ge) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_ge ! Compare (>=) a varying string and a character ! string op_ge = char(string_a) >= string_b ! Finish return end function op_ge_VS_CH !**** elemental function op_gt_VS_VS (string_a, string_b) result (op_gt) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_gt ! Compare (>) two varying strings op_gt = char(string_a) > char(string_b) ! Finish return end function op_gt_VS_VS !**** elemental function op_gt_CH_VS (string_a, string_b) result (op_gt) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_gt ! Compare (>) a character string and a varying ! string op_gt = string_a > char(string_b) ! Finish return end function op_gt_CH_VS !**** elemental function op_gt_VS_CH (string_a, string_b) result (op_gt) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_gt ! Compare (>) a varying string and a character ! string op_gt = char(string_a) > string_b ! Finish return end function op_gt_VS_CH !**** elemental function adjustl_ (string) result (adjustl_string) type(varying_string), intent(in) :: string type(varying_string) :: adjustl_string ! Adjust the varying string to the left adjustl_string = ADJUSTL(CHAR(string)) ! Finish return end function adjustl_ !**** elemental function adjustr_ (string) result (adjustr_string) type(varying_string), intent(in) :: string type(varying_string) :: adjustr_string ! Adjust the varying string to the right adjustr_string = ADJUSTR(CHAR(string)) ! Finish return end function adjustr_ !**** pure function char_auto (string) result (char_string) type(varying_string), intent(in) :: string character(LEN=len(string)) :: char_string integer :: i_char ! Convert a varying string into a character string ! (automatic length) forall(i_char = 1:len(string)) char_string(i_char:i_char) = string%chars(i_char) end forall ! Finish return end function char_auto !**** pure function char_fixed (string, length) result (char_string) type(varying_string), intent(in) :: string integer, intent(in) :: length character(LEN=length) :: char_string ! Convert a varying string into a character string ! (fixed length) char_string = char(string) ! Finish return end function char_fixed !**** elemental function iachar_ (c) result (i) type(varying_string), intent(in) :: c integer :: i ! Get the position in the ISO 646 collating sequence ! of a varying string character i = IACHAR(char(c)) ! Finish return end function iachar_ !**** elemental function ichar_ (c) result (i) type(varying_string), intent(in) :: c integer :: i ! Get the position in the processor collating ! sequence of a varying string character i = ICHAR(char(c)) ! Finish return end function ichar_ !**** elemental function index_VS_VS (string, substring, back) result (i_substring) type(varying_string), intent(in) :: string type(varying_string), intent(in) :: substring logical, intent(in), optional :: back integer :: i_substring ! Get the index of a varying substring within a ! varying string i_substring = INDEX(char(string), char(substring), back) ! Finish return end function index_VS_VS !**** elemental function index_CH_VS (string, substring, back) result (i_substring) character(LEN=*), intent(in) :: string type(varying_string), intent(in) :: substring logical, intent(in), optional :: back integer :: i_substring ! Get the index of a varying substring within a ! character string i_substring = INDEX(string, char(substring), back) ! Finish return end function index_CH_VS !**** elemental function index_VS_CH (string, substring, back) result (i_substring) type(varying_string), intent(in) :: string character(LEN=*), intent(in) :: substring logical, intent(in), optional :: back integer :: i_substring ! Get the index of a character substring within a ! varying string i_substring = INDEX(char(string), substring, back) ! Finish return end function index_VS_CH !**** elemental function len_ (string) result (length) type(varying_string), intent(in) :: string integer :: length ! Get the length of a varying string if(ALLOCATED(string%chars)) then length = SIZE(string%chars) else length = 0 endif ! Finish return end function len_ !**** elemental function len_trim_ (string) result (length) type(varying_string), intent(in) :: string integer :: length ! Get the trimmed length of a varying string if(ALLOCATED(string%chars)) then length = LEN_TRIM(char(string)) else length = 0 endif ! Finish return end function len_trim_ !**** elemental function lge_VS_VS (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LGE) two varying strings comp = LGE(char(string_a), char(string_b)) ! Finish return end function lge_VS_VS !**** elemental function lge_CH_VS (string_a, string_b) result (comp) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LGE) a character string and a varying ! string comp = LGE(string_a, char(string_b)) ! Finish return end function lge_CH_VS !**** elemental function lge_VS_CH (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: comp ! Compare (LGE) a varying string and a character ! string comp = LGE(char(string_a), string_b) ! Finish return end function lge_VS_CH !**** elemental function lgt_VS_VS (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LGT) two varying strings comp = LGT(char(string_a), char(string_b)) ! Finish return end function lgt_VS_VS !**** elemental function lgt_CH_VS (string_a, string_b) result (comp) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LGT) a character string and a varying ! string comp = LGT(string_a, char(string_b)) ! Finish return end function lgt_CH_VS !**** elemental function lgt_VS_CH (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: comp ! Compare (LGT) a varying string and a character ! string comp = LGT(char(string_a), string_b) ! Finish return end function lgt_VS_CH !**** elemental function lle_VS_VS (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LLE) two varying strings comp = LLE(char(string_a), char(string_b)) ! Finish return end function lle_VS_VS !**** elemental function lle_CH_VS (string_a, string_b) result (comp) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LLE) a character string and a varying ! string comp = LLE(string_a, char(string_b)) ! Finish return end function lle_CH_VS !**** elemental function lle_VS_CH (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: comp ! Compare (LLE) a varying string and a character ! string comp = LLE(char(string_a), string_b) ! Finish return end function lle_VS_CH !**** elemental function llt_VS_VS (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LLT) two varying strings comp = LLT(char(string_a), char(string_b)) ! Finish return end function llt_VS_VS !**** elemental function llt_CH_VS (string_a, string_b) result (comp) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: comp ! Compare (LLT) a character string and a varying ! string comp = LLT(string_a, char(string_b)) ! Finish return end function llt_CH_VS !**** elemental function llt_VS_CH (string_a, string_b) result (comp) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: comp ! Compare (LLT) a varying string and a character ! string comp = LLT(char(string_a), string_b) ! Finish return end function llt_VS_CH !**** elemental function repeat_ (string, ncopies) result (repeat_string) type(varying_string), intent(in) :: string integer, intent(in) :: ncopies type(varying_string) :: repeat_string ! Concatenate several copies of a varying string repeat_string = var_str(REPEAT(char(string), ncopies)) ! Finish return end function repeat_ !**** elemental function scan_VS_VS (string, set, back) result (i) type(varying_string), intent(in) :: string type(varying_string), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Scan a varying string for occurrences of ! characters in a varying-string set i = SCAN(char(string), char(set), back) ! Finish return end function scan_VS_VS !**** elemental function scan_CH_VS (string, set, back) result (i) character(LEN=*), intent(in) :: string type(varying_string), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Scan a character string for occurrences of ! characters in a varying-string set i = SCAN(string, char(set), back) ! Finish return end function scan_CH_VS !**** elemental function scan_VS_CH (string, set, back) result (i) type(varying_string), intent(in) :: string character(LEN=*), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Scan a varying string for occurrences of ! characters in a character-string set i = SCAN(char(string), set, back) ! Finish return end function scan_VS_CH !**** elemental function trim_ (string) result (trim_string) type(varying_string), intent(in) :: string type(varying_string) :: trim_string ! Remove trailing blanks from a varying string trim_string = TRIM(char(string)) ! Finish return end function trim_ !**** elemental function verify_VS_VS (string, set, back) result (i) type(varying_string), intent(in) :: string type(varying_string), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Verify a varying string for occurrences of ! characters in a varying-string set i = VERIFY(char(string), char(set), back) ! Finish return end function verify_VS_VS !**** elemental function verify_CH_VS (string, set, back) result (i) character(LEN=*), intent(in) :: string type(varying_string), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Verify a character string for occurrences of ! characters in a varying-string set i = VERIFY(string, char(set), back) ! Finish return end function verify_CH_VS !**** elemental function verify_VS_CH (string, set, back) result (i) type(varying_string), intent(in) :: string character(LEN=*), intent(in) :: set logical, intent(in), optional :: back integer :: i ! Verify a varying string for occurrences of ! characters in a character-string set i = VERIFY(char(string), set, back) ! Finish return end function verify_VS_CH !**** elemental function var_str_ (char) result (string) character(LEN=*), intent(in) :: char type(varying_string) :: string integer :: length integer :: i_char ! Convert a character string to a varying string length = LEN(char) ALLOCATE(string%chars(length)) forall(i_char = 1:length) string%chars(i_char) = char(i_char:i_char) end forall ! Finish return end function var_str_ !**** subroutine get_ (string, maxlen, iostat) type(varying_string), intent(out) :: string integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat integer :: n_chars_remain integer :: n_chars_read character(LEN=GET_BUFFER_LEN) :: buffer ! Read from the default unit into a varying string string = '' if(PRESENT(maxlen)) then n_chars_remain = maxlen else n_chars_remain = HUGE(1) endif read_loop : do if(n_chars_remain <= 0) return n_chars_read = MIN(n_chars_remain, GET_BUFFER_LEN) if(PRESENT(iostat)) then read(*, FMT='(A)', ADVANCE='NO', IOSTAT=iostat, SIZE=n_chars_read) buffer(:n_chars_read) if(iostat < 0) exit read_loop if(iostat > 0) return else read(*, FMT='(A)', ADVANCE='NO', EOR=999, SIZE=n_chars_read) buffer(:n_chars_read) endif string = string//buffer(:n_chars_read) n_chars_remain = n_chars_remain - n_chars_read end do read_loop 999 continue string = string//buffer(:n_chars_read) ! Finish (end-of-record) return end subroutine get_ !**** subroutine get_unit (unit, string, maxlen, iostat) integer, intent(in) :: unit type(varying_string), intent(out) :: string integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat integer :: n_chars_remain integer :: n_chars_read character(LEN=GET_BUFFER_LEN) :: buffer ! Read from the specified unit into a varying string string = '' if(PRESENT(maxlen)) then n_chars_remain = maxlen else n_chars_remain = HUGE(1) endif read_loop : do if(n_chars_remain <= 0) return n_chars_read = MIN(n_chars_remain, GET_BUFFER_LEN) if(PRESENT(iostat)) then read(unit, FMT='(A)', ADVANCE='NO', IOSTAT=iostat, SIZE=n_chars_read) buffer(:n_chars_read) if(iostat < 0) exit read_loop if(iostat > 0) return else read(unit, FMT='(A)', ADVANCE='NO', EOR=999, SIZE=n_chars_read) buffer(:n_chars_read) endif string = string//buffer(:n_chars_read) n_chars_remain = n_chars_remain - n_chars_read end do read_loop 999 continue string = string//buffer(:n_chars_read) ! Finish (end-of-record) return end subroutine get_unit !**** subroutine get_set_VS (string, set, separator, maxlen, iostat) type(varying_string), intent(out) :: string type(varying_string), intent(in) :: set type(varying_string), intent(out), optional :: separator integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat ! Read from the default unit into a varying string, ! with a custom varying-string separator call get(string, char(set), separator, maxlen, iostat) ! Finish return end subroutine get_set_VS !**** subroutine get_set_CH (string, set, separator, maxlen, iostat) type(varying_string), intent(out) :: string character(LEN=*), intent(in) :: set type(varying_string), intent(out), optional :: separator integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat integer :: n_chars_remain character(LEN=1) :: buffer integer :: i_set ! Read from the default unit into a varying string, ! with a custom character-string separator string = '' if(PRESENT(maxlen)) then n_chars_remain = maxlen else n_chars_remain = HUGE(1) endif if(PRESENT(separator)) separator = '' read_loop : do if(n_chars_remain <= 0) return if(PRESENT(iostat)) then read(*, FMT='(A1)', ADVANCE='NO', IOSTAT=iostat) buffer if(iostat /= 0) exit read_loop else read(*, FMT='(A1)', ADVANCE='NO', EOR=999) buffer endif i_set = SCAN(buffer, set) if(i_set == 1) then if(PRESENT(separator)) separator = buffer exit read_loop endif string = string//buffer n_chars_remain = n_chars_remain - 1 end do read_loop 999 continue ! Finish return end subroutine get_set_CH !**** subroutine get_unit_set_VS (unit, string, set, separator, maxlen, iostat) integer, intent(in) :: unit type(varying_string), intent(out) :: string type(varying_string), intent(in) :: set type(varying_string), intent(out), optional :: separator integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat ! Read from the specified unit into a varying string, ! with a custom varying-string separator call get(unit, string, char(set), separator, maxlen, iostat) ! Finish return end subroutine get_unit_set_VS !**** subroutine get_unit_set_CH (unit, string, set, separator, maxlen, iostat) integer, intent(in) :: unit type(varying_string), intent(out) :: string character(LEN=*), intent(in) :: set type(varying_string), intent(out), optional :: separator integer, intent(in), optional :: maxlen integer, intent(out), optional :: iostat integer :: n_chars_remain character(LEN=1) :: buffer integer :: i_set ! Read from the default unit into a varying string, ! with a custom character-string separator string = '' if(PRESENT(maxlen)) then n_chars_remain = maxlen else n_chars_remain = HUGE(1) endif if(PRESENT(separator)) separator = '' read_loop : do if(n_chars_remain <= 0) return if(PRESENT(iostat)) then read(unit, FMT='(A1)', ADVANCE='NO', IOSTAT=iostat) buffer if(iostat /= 0) exit read_loop else read(unit, FMT='(A1)', ADVANCE='NO', EOR=999) buffer endif i_set = SCAN(buffer, set) if(i_set == 1) then if(PRESENT(separator)) separator = buffer exit read_loop endif string = string//buffer n_chars_remain = n_chars_remain - 1 end do read_loop 999 continue ! Finish return end subroutine get_unit_set_CH !**** subroutine put_VS (string, iostat) type(varying_string), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the default unit call put(char(string), iostat) ! Finish end subroutine put_VS !**** subroutine put_CH (string, iostat) character(LEN=*), intent(in) :: string integer, intent(out), optional :: iostat ! Append a character string to the current record of ! the default unit if(PRESENT(iostat)) then write(*, FMT='(A)', ADVANCE='NO', IOSTAT=iostat) string else write(*, FMT='(A)', ADVANCE='NO') string endif ! Finish end subroutine put_CH !**** subroutine put_unit_VS (unit, string, iostat) integer, intent(in) :: unit type(varying_string), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the specified unit call put(unit, char(string), iostat) ! Finish return end subroutine put_unit_VS !**** subroutine put_unit_CH (unit, string, iostat) integer, intent(in) :: unit character(LEN=*), intent(in) :: string integer, intent(out), optional :: iostat ! Append a character string to the current record of ! the specified unit if(PRESENT(iostat)) then write(unit, FMT='(A)', ADVANCE='NO', IOSTAT=iostat) string else write(unit, FMT='(A)', ADVANCE='NO') string endif ! Finish return end subroutine put_unit_CH !**** subroutine put_line_VS (string, iostat) type(varying_string), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the default unit, terminating the record call put_line(char(string), iostat) ! Finish return end subroutine put_line_VS !**** subroutine put_line_CH (string, iostat) character(LEN=*), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the default unit, terminating the record if(PRESENT(iostat)) then write(*, FMT='(A,/)', ADVANCE='NO', IOSTAT=iostat) string else write(*, FMT='(A,/)', ADVANCE='NO') string endif ! Finish return end subroutine put_line_CH !**** subroutine put_line_unit_VS (unit, string, iostat) integer, intent(in) :: unit type(varying_string), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the specified unit, terminating the record call put_line(unit, char(string), iostat) ! Finish return end subroutine put_line_unit_VS !**** subroutine put_line_unit_CH (unit, string, iostat) integer, intent(in) :: unit character(LEN=*), intent(in) :: string integer, intent(out), optional :: iostat ! Append a varying string to the current record of ! the specified unit, terminating the record if(PRESENT(iostat)) then write(unit, FMT='(A,/)', ADVANCE='NO', IOSTAT=iostat) string else write(unit, FMT='(A,/)', ADVANCE='NO') string endif ! Finish return end subroutine put_line_unit_CH !**** elemental function extract_VS (string, start, finish) result (ext_string) type(varying_string), intent(in) :: string integer, intent(in), optional :: start integer, intent(in), optional :: finish type(varying_string) :: ext_string ! Extract a varying substring from a varying string ext_string = extract(char(string), start, finish) ! Finish return end function extract_VS !**** elemental function extract_CH (string, start, finish) result (ext_string) character(LEN=*), intent(in) :: string integer, intent(in), optional :: start integer, intent(in), optional :: finish type(varying_string) :: ext_string integer :: start_ integer :: finish_ ! Extract a varying substring from a character string if(PRESENT(start)) then start_ = MAX(1, start) else start_ = 1 endif if(PRESENT(finish)) then finish_ = MIN(LEN(string), finish) else finish_ = LEN(string) endif ext_string = var_str(string(start_:finish_)) ! Finish return end function extract_CH !**** elemental function insert_VS_VS (string, start, substring) result (ins_string) type(varying_string), intent(in) :: string integer, intent(in) :: start type(varying_string), intent(in) :: substring type(varying_string) :: ins_string ! Insert a varying substring into a varying string ins_string = insert(char(string), start, char(substring)) ! Finish return end function insert_VS_VS !**** elemental function insert_CH_VS (string, start, substring) result (ins_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start type(varying_string), intent(in) :: substring type(varying_string) :: ins_string ! Insert a varying substring into a character string ins_string = insert(string, start, char(substring)) ! Finish return end function insert_CH_VS !**** elemental function insert_VS_CH (string, start, substring) result (ins_string) type(varying_string), intent(in) :: string integer, intent(in) :: start character(LEN=*), intent(in) :: substring type(varying_string) :: ins_string ! Insert a character substring into a varying string ins_string = insert(char(string), start, substring) ! Finish return end function insert_VS_CH !**** elemental function insert_CH_CH (string, start, substring) result (ins_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start character(LEN=*), intent(in) :: substring type(varying_string) :: ins_string integer :: start_ ! Insert a character substring into a character ! string start_ = MAX(1, MIN(start, LEN(string)+1)) ins_string = var_str(string(:start_-1)//substring//string(start_:)) ! Finish return end function insert_CH_CH !**** elemental function remove_VS (string, start, finish) result (rem_string) type(varying_string), intent(in) :: string integer, intent(in), optional :: start integer, intent(in), optional :: finish type(varying_string) :: rem_string ! Remove a substring from a varying string rem_string = remove(char(string), start, finish) ! Finish return end function remove_VS !**** elemental function remove_CH (string, start, finish) result (rem_string) character(LEN=*), intent(in) :: string integer, intent(in), optional :: start integer, intent(in), optional :: finish type(varying_string) :: rem_string integer :: start_ integer :: finish_ ! Remove a substring from a character string if(PRESENT(start)) then start_ = MAX(1, start) else start_ = 1 endif if(PRESENT(finish)) then finish_ = MIN(LEN(string), finish) else finish_ = LEN(string) endif if(finish_ >= start_) then rem_string = var_str(string(:start_-1)//string(finish_+1:)) else rem_string = string endif ! Finish return end function remove_CH !**** elemental function replace_VS_VS_auto (string, start, substring) result (rep_string) type(varying_string), intent(in) :: string integer, intent(in) :: start type(varying_string), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a varying string with a varying ! substring rep_string = replace(char(string), start, MAX(start, 1)+len(substring)-1, char(substring)) ! Finish return end function replace_VS_VS_auto !**** elemental function replace_CH_VS_auto (string, start, substring) result (rep_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start type(varying_string), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a character string with a varying ! substring rep_string = replace(string, start, MAX(start, 1)+len(substring)-1, char(substring)) ! Finish return end function replace_CH_VS_auto !**** elemental function replace_VS_CH_auto (string, start, substring) result (rep_string) type(varying_string), intent(in) :: string integer, intent(in) :: start character(LEN=*), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a varying string with a character ! substring rep_string = replace(char(string), start, MAX(start, 1)+LEN(substring)-1, substring) ! Finish return end function replace_VS_CH_auto !**** elemental function replace_CH_CH_auto (string, start, substring) result (rep_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start character(LEN=*), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a character string with a character ! substring rep_string = replace(string, start, MAX(start, 1)+LEN(substring)-1, substring) ! Finish return end function replace_CH_CH_auto !**** elemental function replace_VS_VS_fixed (string, start, finish, substring) result (rep_string) type(varying_string), intent(in) :: string integer, intent(in) :: start integer, intent(in) :: finish type(varying_string), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a varying string with a varying ! substring rep_string = replace(char(string), start, finish, char(substring)) ! Finish return end function replace_VS_VS_fixed !**** !**** elemental function replace_CH_VS_fixed (string, start, finish, substring) result (rep_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start integer, intent(in) :: finish type(varying_string), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a character string with a varying ! substring rep_string = replace(string, start, finish, char(substring)) ! Finish return end function replace_CH_VS_fixed !**** elemental function replace_VS_CH_fixed (string, start, finish, substring) result (rep_string) type(varying_string), intent(in) :: string integer, intent(in) :: start integer, intent(in) :: finish character(LEN=*), intent(in) :: substring type(varying_string) :: rep_string ! Replace part of a varying string with a character ! substring rep_string = replace(char(string), start, finish, substring) ! Finish return end function replace_VS_CH_fixed !**** elemental function replace_CH_CH_fixed (string, start, finish, substring) result (rep_string) character(LEN=*), intent(in) :: string integer, intent(in) :: start integer, intent(in) :: finish character(LEN=*), intent(in) :: substring type(varying_string) :: rep_string integer :: start_ integer :: finish_ ! Replace part of a character string with a character ! substring start_ = MAX(1, start) finish_ = MIN(LEN(string), finish) if(finish_ < start_) then rep_string = insert(string, start_, substring) else rep_string = var_str(string(:start_-1)//substring//string(finish_+1:)) endif ! Finish return end function replace_CH_CH_fixed !**** elemental function replace_VS_VS_VS_target (string, target, substring, every, back) result (rep_string) type(varying_string), intent(in) :: string type(varying_string), intent(in) :: target type(varying_string), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a varying string with a varying ! substring, at a location matching a varying- ! string target rep_string = replace(char(string), char(target), char(substring), every, back) ! Finish return end function replace_VS_VS_VS_target !**** elemental function replace_CH_VS_VS_target (string, target, substring, every, back) result (rep_string) character(LEN=*), intent(in) :: string type(varying_string), intent(in) :: target type(varying_string), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a character string with a varying ! substring, at a location matching a varying- ! string target rep_string = replace(string, char(target), char(substring), every, back) ! Finish return end function replace_CH_VS_VS_target !**** elemental function replace_VS_CH_VS_target (string, target, substring, every, back) result (rep_string) type(varying_string), intent(in) :: string character(LEN=*), intent(in) :: target type(varying_string), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a character string with a varying ! substring, at a location matching a character- ! string target rep_string = replace(char(string), target, char(substring), every, back) ! Finish return end function replace_VS_CH_VS_target !**** elemental function replace_CH_CH_VS_target (string, target, substring, every, back) result (rep_string) character(LEN=*), intent(in) :: string character(LEN=*), intent(in) :: target type(varying_string), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a character string with a varying ! substring, at a location matching a character- ! string target rep_string = replace(string, target, char(substring), every, back) ! Finish return end function replace_CH_CH_VS_target !**** elemental function replace_VS_VS_CH_target (string, target, substring, every, back) result (rep_string) type(varying_string), intent(in) :: string type(varying_string), intent(in) :: target character(LEN=*), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a varying string with a character ! substring, at a location matching a varying- ! string target rep_string = replace(char(string), char(target), substring, every, back) ! Finish return end function replace_VS_VS_CH_target !**** elemental function replace_CH_VS_CH_target (string, target, substring, every, back) result (rep_string) character(LEN=*), intent(in) :: string type(varying_string), intent(in) :: target character(LEN=*), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a character string with a character ! substring, at a location matching a varying- ! string target rep_string = replace(string, char(target), substring, every, back) ! Finish return end function replace_CH_VS_CH_target !**** elemental function replace_VS_CH_CH_target (string, target, substring, every, back) result (rep_string) type(varying_string), intent(in) :: string character(LEN=*), intent(in) :: target character(LEN=*), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string ! Replace part of a varying string with a character ! substring, at a location matching a character- ! string target rep_string = replace(char(string), target, substring, every, back) ! Finish return end function replace_VS_CH_CH_target !**** elemental function replace_CH_CH_CH_target (string, target, substring, every, back) result (rep_string) character(LEN=*), intent(in) :: string character(LEN=*), intent(in) :: target character(LEN=*), intent(in) :: substring logical, intent(in), optional :: every logical, intent(in), optional :: back type(varying_string) :: rep_string logical :: every_ logical :: back_ type(varying_string) :: work_string integer :: length_target integer :: i_target ! Handle special cases when LEN(target) == 0. Such ! instances are prohibited by the standard, but ! since this function is elemental, no error can be ! thrown. Therefore, it makes sense to handle them ! in a sensible manner if(LEN(target) == 0) then if(LEN(string) /= 0) then rep_string = string else rep_string = substring endif return end if ! Replace part of a character string with a character ! substring, at a location matching a character- ! string target if(PRESENT(every)) then every_ = every else every_ = .false. endif if(PRESENT(back)) then back_ = back else back_ = .false. endif rep_string = '' work_string = string length_target = LEN(target) replace_loop : do i_target = index(work_string, target, back_) if(i_target == 0) exit replace_loop if(back_) then rep_string = substring//extract(work_string, start=i_target+length_target)//rep_string work_string = extract(work_string, finish=i_target-1) else rep_string = rep_string//extract(work_string, finish=i_target-1)//substring work_string = extract(work_string, start=i_target+length_target) endif if(.NOT. every_) exit replace_loop end do replace_loop if(back_) then rep_string = work_string//rep_string else rep_string = rep_string//work_string endif ! Finish return end function replace_CH_CH_CH_target !**** elemental subroutine split_VS (string, word, set, separator, back) type(varying_string), intent(inout) :: string type(varying_string), intent(out) :: word type(varying_string), intent(in) :: set type(varying_string), intent(out), optional :: separator logical, intent(in), optional :: back ! Split a varying string into two verying strings call split_CH(string, word, char(set), separator, back) ! Finish return end subroutine split_VS !**** elemental subroutine split_CH (string, word, set, separator, back) type(varying_string), intent(inout) :: string type(varying_string), intent(out) :: word character(LEN=*), intent(in) :: set type(varying_string), intent(out), optional :: separator logical, intent(in), optional :: back logical :: back_ integer :: i_separator ! Split a varying string into two verying strings if(PRESENT(back)) then back_ = back else back_ = .false. endif i_separator = scan(string, set, back_) if(i_separator /= 0) then if(back_) then word = extract(string, start=i_separator+1) if(PRESENT(separator)) separator = extract(string, start=i_separator, finish=i_separator) string = extract(string, finish=i_separator-1) else word = extract(string, finish=i_separator-1) if(PRESENT(separator)) separator = extract(string, start=i_separator, finish=i_separator) string = extract(string, start=i_separator+1) endif else word = string if(PRESENT(separator)) separator = '' string = '' endif ! Finish return end subroutine split_CH end module iso_varying_string !#################################################################################################################################### program test_iso ! uses iso_varying_string from http://zuserver2.star.ucl.ac.uk/~rhdt/download/fortran/iso_varying_string.f90 use iso_varying_string implicit none character(len=80) :: str="" character(len=260) :: textfile="" type(varying_string) :: v_str integer :: i, ios character(len=1) :: newlinechar=";" ! read in a text file of your own choosing write (*, '(/"Enter the name of any text file: ")', advance='NO') read (*,'(A260)') textfile ! text.dat is an ASCII text file open (unit=1,file=textfile, status='OLD', iostat=ios) write (*,'("iostat on opening file= ",I0)') ios if (ios.ne.0) stop 'Could not open file' i = 0 ! 1. read as a character string write(*, '(/"read as a character string..."/)') do read(1,'(A80)', iostat=ios) str if (ios.GT.0) stop 'Error on formatted read' if (ios.EQ.-1) exit i = i + 1 print *, i, trim(str) enddo rewind(unit=1, iostat=ios) write (*,'(/"iostat on rewind= ",I0)') ios i = 0 ! 2. read as an iso_varying_string without set write(*, '(/"read as an iso_varying_string without optional SET..."/)') do CALL get(unit=1,string=v_str, iostat=ios) if (ios.GT.0) stop 'Error on vs1 read' if (ios.EQ.-1) exit i = i + 1 print *, i, trim(char(v_str)) enddo rewind(unit=1, iostat=ios) write (*,'(/"iostat on rewind= ",I0)') ios i = 0 ! 3. read as an iso_varying_string WITH 'set'... write(*, '(/"read as an iso_varying_string with optional SET..."/)') do CALL get(unit=1,string=v_str, set=newlinechar, iostat=ios) if (ios.GT.0) stop 'Error on vs2 read' if (ios.EQ.-1) exit i = i + 1 print *, i, trim(char(v_str)) enddo stop "Done." end -- Summary: run time error (crash) - optional arguments, generics, interface problem, iso_varying_string ?? Product: gcc Version: 4.4.0 Status: UNCONFIRMED Severity: normal Priority: P3 Component: fortran AssignedTo: unassigned at gcc dot gnu dot org ReportedBy: davidgkinniburgh at yahoo dot co dot uk GCC build triplet: gcc version 4.4.0 20081219 (experimental) [trunk revision 142842 GCC host triplet: Win64 Vista Home GCC target triplet: i586-pc-mingw32 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=38602