From 5b0a85fb2edd25d475bb9d773c2888ec9029cfad Mon Sep 17 00:00:00 2001
From: Ivan Pribec <ivan.pribec@gmail.com>
Date: Sat, 28 Dec 2019 18:54:01 +0100
Subject: [PATCH] Place ASCII control characters in derived type; replace
whitechar in IO module with is_blank.
---
src/stdlib_experimental_ascii.f90 | 219 ++++++++++++++++--------------
src/stdlib_experimental_io.f90 | 21 +--
src/tests/ascii/test_ascii.f90 | 197 ++++++++++++++++++---------
3 files changed, 254 insertions(+), 183 deletions(-)
diff --git a/src/stdlib_experimental_ascii.f90 b/src/stdlib_experimental_ascii.f90
index fd7910790..19c173ef7 100644
--- a/src/stdlib_experimental_ascii.f90
+++ b/src/stdlib_experimental_ascii.f90
@@ -1,118 +1,135 @@
module stdlib_experimental_ascii
- implicit none
- private
-
- ! Character validation functions
- public :: is_alpha, is_alphanum
- public :: is_digit, is_hex_digit, is_octal_digit
- public :: is_control, is_white, is_blank
- public :: is_ascii, is_punctuation
- public :: is_graphical, is_printable
- public :: is_lower, is_upper
-
- ! Character conversion functions
- public :: to_lower, to_upper
-
- ! All control characters in the ASCII table (see www.asciitable.com).
- character(len=1), public, parameter :: NUL = achar(z'00') !! Null
- character(len=1), public, parameter :: SOH = achar(z'01') !! Start of heading
- character(len=1), public, parameter :: STX = achar(z'02') !! Start of text
- character(len=1), public, parameter :: ETX = achar(z'03') !! End of text
- character(len=1), public, parameter :: EOT = achar(z'04') !! End of transmission
- character(len=1), public, parameter :: ENQ = achar(z'05') !! Enquiry
- character(len=1), public, parameter :: ACK = achar(z'06') !! Acknowledge
- character(len=1), public, parameter :: BEL = achar(z'07') !! Bell
- character(len=1), public, parameter :: BS = achar(z'08') !! Backspace
- character(len=1), public, parameter :: TAB = achar(z'09') !! Horizontal tab
- character(len=1), public, parameter :: LF = achar(z'0A') !! NL line feed, new line
- character(len=1), public, parameter :: VT = achar(z'0B') !! Vertical tab
- character(len=1), public, parameter :: FF = achar(z'0C') !! NP form feed, new page
- character(len=1), public, parameter :: CR = achar(z'0D') !! Carriage return
- character(len=1), public, parameter :: SO = achar(z'0E') !! Shift out
- character(len=1), public, parameter :: SI = achar(z'0F') !! Shift in
- character(len=1), public, parameter :: DLE = achar(z'10') !! Data link escape
- character(len=1), public, parameter :: DC1 = achar(z'11') !! Device control 1
- character(len=1), public, parameter :: DC2 = achar(z'12') !! Device control 2
- character(len=1), public, parameter :: DC3 = achar(z'13') !! Device control 3
- character(len=1), public, parameter :: DC4 = achar(z'14') !! Device control 4
- character(len=1), public, parameter :: NAK = achar(z'15') !! Negative acknowledge
- character(len=1), public, parameter :: SYN = achar(z'16') !! Synchronous idle
- character(len=1), public, parameter :: ETB = achar(z'17') !! End of transmission block
- character(len=1), public, parameter :: CAN = achar(z'18') !! Cancel
- character(len=1), public, parameter :: EM = achar(z'19') !! End of medium
- character(len=1), public, parameter :: SUB = achar(z'1A') !! Substitute
- character(len=1), public, parameter :: ESC = achar(z'1B') !! Escape
- character(len=1), public, parameter :: FS = achar(z'1C') !! File separator
- character(len=1), public, parameter :: GS = achar(z'1D') !! Group separator
- character(len=1), public, parameter :: RS = achar(z'1E') !! Record separator
- character(len=1), public, parameter :: US = achar(z'1F') !! Unit separator
- character(len=1), public, parameter :: DEL = achar(z'7F') !! Delete
-
- ! Constant character sequences
- character(len=*), public, parameter :: fullhex_digits = "0123456789ABCDEFabcdef" !! 0 .. 9A .. Fa .. f
- character(len=*), public, parameter :: hex_digits = fullhex_digits(1:16) !! 0 .. 9A .. F
- character(len=*), public, parameter :: lowerhex_digits = "0123456789abcdef" !! 0 .. 9a .. f
- character(len=*), public, parameter :: digits = hex_digits(1:10) !! 0 .. 9
- character(len=*), public, parameter :: octal_digits = digits(1:8) !! 0 .. 7
- character(len=*), public, parameter :: letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" !! A .. Za .. z
- character(len=*), public, parameter :: uppercase = letters(1:26) !! A .. Z
- character(len=*), public, parameter :: lowercase = letters(27:) !! a .. z
- character(len=*), public, parameter :: whitespace = " "//TAB//VT//CR//LF//FF !! ASCII _whitespace
+implicit none
+private
+
+! Character validation functions
+public :: is_alpha, is_alphanum
+public :: is_digit, is_hex_digit, is_octal_digit
+public :: is_control, is_white, is_blank
+public :: is_ascii, is_punctuation
+public :: is_graphical, is_printable
+public :: is_lower, is_upper
+
+! Character conversion functions
+public :: to_lower, to_upper
+
+! Ascii control characters
+public :: ascii_control_char
+
+! Constant character sequences
+public :: fullhex_digits, hex_digits, lowerhex_digits, digits, octal_digits
+public :: letters, uppercase, lowercase, whitespace
+
+
+! All control characters in the ASCII table (see www.asciitable.com).
+type :: ascii_control_char_t
+ character(len=1) :: NUL = achar(z'00') !! Null
+ character(len=1) :: SOH = achar(z'01') !! Start of heading
+ character(len=1) :: STX = achar(z'02') !! Start of text
+ character(len=1) :: ETX = achar(z'03') !! End of text
+ character(len=1) :: EOT = achar(z'04') !! End of transmission
+ character(len=1) :: ENQ = achar(z'05') !! Enquiry
+ character(len=1) :: ACK = achar(z'06') !! Acknowledge
+ character(len=1) :: BEL = achar(z'07') !! Bell
+ character(len=1) :: BS = achar(z'08') !! Backspace
+ character(len=1) :: TAB = achar(z'09') !! Horizontal tab
+ character(len=1) :: LF = achar(z'0A') !! NL line feed, new line
+ character(len=1) :: VT = achar(z'0B') !! Vertical tab
+ character(len=1) :: FF = achar(z'0C') !! NP form feed, new page
+ character(len=1) :: CR = achar(z'0D') !! Carriage return
+ character(len=1) :: SO = achar(z'0E') !! Shift out
+ character(len=1) :: SI = achar(z'0F') !! Shift in
+ character(len=1) :: DLE = achar(z'10') !! Data link escape
+ character(len=1) :: DC1 = achar(z'11') !! Device control 1
+ character(len=1) :: DC2 = achar(z'12') !! Device control 2
+ character(len=1) :: DC3 = achar(z'13') !! Device control 3
+ character(len=1) :: DC4 = achar(z'14') !! Device control 4
+ character(len=1) :: NAK = achar(z'15') !! Negative acknowledge
+ character(len=1) :: SYN = achar(z'16') !! Synchronous idle
+ character(len=1) :: ETB = achar(z'17') !! End of transmission block
+ character(len=1) :: CAN = achar(z'18') !! Cancel
+ character(len=1) :: EM = achar(z'19') !! End of medium
+ character(len=1) :: SUB = achar(z'1A') !! Substitute
+ character(len=1) :: ESC = achar(z'1B') !! Escape
+ character(len=1) :: FS = achar(z'1C') !! File separator
+ character(len=1) :: GS = achar(z'1D') !! Group separator
+ character(len=1) :: RS = achar(z'1E') !! Record separator
+ character(len=1) :: US = achar(z'1F') !! Unit separator
+ character(len=1) :: DEL = achar(z'7F') !! Delete
+end type
+
+! A single instance of the ascii control characters (initialized to default values)
+type(ascii_control_char_t), parameter :: ascii_control_char = ascii_control_char_t()
+
+! Constant character sequences
+character(len=*), parameter :: fullhex_digits = "0123456789ABCDEFabcdef" !! 0 .. 9A .. Fa .. f
+character(len=*), parameter :: hex_digits = fullhex_digits(1:16) !! 0 .. 9A .. F
+character(len=*), parameter :: lowerhex_digits = "0123456789abcdef" !! 0 .. 9a .. f
+character(len=*), parameter :: digits = hex_digits(1:10) !! 0 .. 9
+character(len=*), parameter :: octal_digits = digits(1:8) !! 0 .. 7
+character(len=*), parameter :: letters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" !! A .. Za .. z
+character(len=*), parameter :: uppercase = letters(1:26) !! A .. Z
+character(len=*), parameter :: lowercase = letters(27:) !! a .. z
+character(len=*), parameter :: whitespace = " "//ascii_control_char%TAB//&
+ ascii_control_char%VT//&
+ ascii_control_char%CR//&
+ ascii_control_char%LF//&
+ ascii_control_char%FF !! ASCII whitespace
contains
- !> Checks whether `c` is an ASCII letter (A .. Z, a .. z).
- pure logical function is_alpha(c)
+!> Checks whether `c` is an ASCII letter (A .. Z, a .. z).
+ elemental logical function is_alpha(c)
character(len=1), intent(in) :: c !! The character to test.
is_alpha = (c >= 'A' .and. c <= 'Z') .or. (c >= 'a' .and. c <= 'z')
end function
- !> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z).
- pure logical function is_alphanum(c)
+!> Checks whether `c` is a letter or a number (0 .. 9, a .. z, A .. Z).
+ elemental logical function is_alphanum(c)
character(len=1), intent(in) :: c !! The character to test.
is_alphanum = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'z') &
.or. (c >= 'A' .and. c <= 'Z')
end function
- !> Checks whether or not `c` is in the ASCII character set -
- ! i.e. in the range 0 .. 0x7F.
- pure logical function is_ascii(c)
+!> Checks whether or not `c` is in the ASCII character set -
+! i.e. in the range 0 .. 0x7F.
+ elemental logical function is_ascii(c)
character(len=1), intent(in) :: c !! The character to test.
is_ascii = iachar(c) <= z'7F'
end function
- !> Checks whether `c` is a control character.
- pure logical function is_control(c)
+!> Checks whether `c` is a control character.
+ elemental logical function is_control(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c)
is_control = ic < z'20' .or. ic == z'7F'
end function
- !> Checks whether `c` is a digit (0 .. 9).
- pure logical function is_digit(c)
+!> Checks whether `c` is a digit (0 .. 9).
+ elemental logical function is_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_digit = ('0' <= c) .and. (c <= '9')
end function
- !> Checks whether `c` is a digit in base 8 (0 .. 7).
- pure logical function is_octal_digit(c)
+!> Checks whether `c` is a digit in base 8 (0 .. 7).
+ elemental logical function is_octal_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_octal_digit = (c >= '0') .and. (c <= '7');
end function
- !> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f).
- pure logical function is_hex_digit(c)
+!> Checks whether `c` is a digit in base 16 (0 .. 9, A .. F, a .. f).
+ elemental logical function is_hex_digit(c)
character(len=1), intent(in) :: c !! The character to test.
is_hex_digit = (c >= '0' .and. c <= '9') .or. (c >= 'a' .and. c <= 'f') &
.or. (c >= 'A' .and. c <= 'F')
end function
- !> Checks whether or not `c` is a punctuation character. That includes
- ! all ASCII characters which are not control characters, letters,
- ! digits, or whitespace.
- pure logical function is_punctuation(c)
+!> Checks whether or not `c` is a punctuation character. That includes
+! all ASCII characters which are not control characters, letters,
+! digits, or whitespace.
+ elemental logical function is_punctuation(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! '~' '!'
@@ -120,58 +137,58 @@ pure logical function is_punctuation(c)
(.not. is_alphanum(c))
end function
- !> Checks whether or not `c` is a printable character other than the
- ! space character.
- pure logical function is_graphical(c)
+!> Checks whether or not `c` is a printable character other than the
+! space character.
+ elemental logical function is_graphical(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! '!' '~'
is_graphical = (z'21' <= ic) .and. (ic <= z'7E')
end function
- !> Checks whether or not `c` is a printable character - including the
- ! space character.
- pure logical function is_printable(c)
+!> Checks whether or not `c` is a printable character - including the
+! space character.
+ elemental logical function is_printable(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! '~'
is_printable = c >= ' ' .and. ic <= z'7E'
end function
- !> Checks whether `c` is a lowercase ASCII letter (a .. z).
- pure logical function is_lower(c)
+!> Checks whether `c` is a lowercase ASCII letter (a .. z).
+ elemental logical function is_lower(c)
character(len=1), intent(in) :: c !! The character to test.
is_lower = (c >= 'a') .and. (c <= 'z')
end function
- !> Checks whether `c` is an uppercase ASCII letter (A .. Z).
- pure logical function is_upper(c)
+!> Checks whether `c` is an uppercase ASCII letter (A .. Z).
+ elemental logical function is_upper(c)
character(len=1), intent(in) :: c !! The character to test.
is_upper = (c >= 'A') .and. (c <= 'Z')
end function
- !> Checks whether or not `c` is a whitespace character. That includes the
- ! space, tab, vertical tab, form feed, carriage return, and linefeed
- ! characters.
- pure logical function is_white(c)
+!> Checks whether or not `c` is a whitespace character. That includes the
+! space, tab, vertical tab, form feed, carriage return, and linefeed
+! characters.
+ elemental logical function is_white(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! TAB, LF, VT, FF, CR
is_white = (c == ' ') .or. (ic >= z'09' .and. ic <= z'0D');
end function
- !> Checks whether or not `c` is a blank character. That includes the
- ! only the space and tab characters
- pure logical function is_blank(c)
+!> Checks whether or not `c` is a blank character. That includes
+! the space and tab characters
+ elemental logical function is_blank(c)
character(len=1), intent(in) :: c !! The character to test.
integer :: ic
ic = iachar(c) ! TAB
is_blank = (c == ' ') .or. (ic == z'09');
end function
- !> Returns the corresponding lowercase letter, if `c` is an uppercase
- ! ASCII character, otherwise `c` itself.
- pure function to_lower(c) result(t)
+!> Returns the corresponding lowercase letter, if `c` is an uppercase
+! ASCII character, otherwise `c` itself.
+ elemental function to_lower(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer :: diff
@@ -181,9 +198,9 @@ pure function to_lower(c) result(t)
if (is_upper(t)) t = achar(iachar(t) - diff)
end function
- !> Returns the corresponding uppercase letter, if `c` is a lowercase
- ! ASCII character, otherwise `c` itself.
- pure function to_upper(c) result(t)
+!> Returns the corresponding uppercase letter, if `c` is a lowercase
+! ASCII character, otherwise `c` itself.
+ elemental function to_upper(c) result(t)
character(len=1), intent(in) :: c !! A character.
character(len=1) :: t
integer :: diff
diff --git a/src/stdlib_experimental_io.f90 b/src/stdlib_experimental_io.f90
index 0e0ca6bab..66bd524ef 100644
--- a/src/stdlib_experimental_io.f90
+++ b/src/stdlib_experimental_io.f90
@@ -1,5 +1,6 @@
module stdlib_experimental_io
use iso_fortran_env, only: sp=>real32, dp=>real64, qp=>real128
+use stdlib_experimental_ascii, only: is_blank
implicit none
private
public :: loadtxt, savetxt
@@ -224,16 +225,16 @@ integer function number_of_columns(s)
integer :: ios
character :: c
- logical :: lastwhite
+ logical :: lastblank
rewind(s)
number_of_columns = 0
- lastwhite = .true.
+ lastblank = .true.
do
read(s, '(a)', advance='no', iostat=ios) c
if (ios /= 0) exit
- if (lastwhite .and. .not. whitechar(c)) number_of_columns = number_of_columns + 1
- lastwhite = whitechar(c)
+ if (lastblank .and. .not. is_blank(c)) number_of_columns = number_of_columns + 1
+ lastblank = is_blank(c)
end do
rewind(s)
@@ -244,7 +245,7 @@ integer function number_of_rows_numeric(s)
integer,intent(in)::s
integer :: ios
- real::r
+ real :: r
rewind(s)
number_of_rows_numeric = 0
@@ -258,14 +259,4 @@ integer function number_of_rows_numeric(s)
end function
-logical function whitechar(char) ! white character
-! returns .true. if char is space (32) or tab (9), .false. otherwise
-character, intent(in) :: char
-if (iachar(char) == 32 .or. iachar(char) == 9) then
- whitechar = .true.
-else
- whitechar = .false.
-end if
-end function
-
end module
diff --git a/src/tests/ascii/test_ascii.f90 b/src/tests/ascii/test_ascii.f90
index 5a535f2ce..88d2e9c88 100644
--- a/src/tests/ascii/test_ascii.f90
+++ b/src/tests/ascii/test_ascii.f90
@@ -6,7 +6,7 @@ program test_ascii
whitespace, letters, is_alphanum, is_alpha, is_lower, is_upper, &
is_digit, is_octal_digit, is_hex_digit, is_white, is_blank, &
is_control, is_punctuation, is_graphical, is_printable, is_ascii, &
- to_lower, to_upper, LF, TAB, NUL, DEL
+ to_lower, to_upper, ascii_control_char
write(*,*) "Lowercase letters: ", lowercase
write(*,*) "Uppercase letters: ", uppercase
@@ -15,6 +15,7 @@ program test_ascii
write(*,*) "Full hex digits: ", fullhex_digits
write(*,*) "Hex digits: ", hex_digits
write(*,*) "Lower hex digits: ", lowerhex_digits
+ write(*,*)
call test_is_alphanum_short
call test_is_alphanum_long
@@ -64,7 +65,7 @@ program test_ascii
call test_to_upper_short
call test_to_upper_long
- ! call test_ascii_table
+ call test_ascii_table
contains
@@ -248,8 +249,8 @@ subroutine test_is_hex_digit_long
subroutine test_is_white_short
write(*,*) "test_is_white_short"
call assert(is_white(' '))
- call assert(is_white(TAB))
- call assert(is_white(LF))
+ call assert(is_white(ascii_control_char%TAB))
+ call assert(is_white(ascii_control_char%LF))
call assert(.not. is_white('1'))
call assert(.not. is_white('a'))
call assert(.not. is_white('#'))
@@ -271,7 +272,7 @@ subroutine test_is_white_long
subroutine test_is_blank_short
write(*,*) "test_is_blank_short"
call assert(is_blank(' '))
- call assert(is_blank(TAB))
+ call assert(is_blank(ascii_control_char%TAB))
call assert(.not. is_blank('1'))
call assert(.not. is_blank('a'))
call assert(.not. is_blank('#'))
@@ -282,7 +283,8 @@ subroutine test_is_blank_long
character(len=:), allocatable :: clist
write(*,*) "test_is_blank_long"
do i = 1, len(whitespace)
- if (whitespace(i:i) == ' ' .or. whitespace(i:i) == TAB) then
+ if (whitespace(i:i) == ' ' .or. &
+ whitespace(i:i) == ascii_control_char%TAB) then
call assert(is_blank(whitespace(i:i)))
else
call assert(.not. is_blank(whitespace(i:i)))
@@ -317,7 +319,7 @@ subroutine test_is_control_long
do i = 0, 31
call assert(is_control(achar(i)))
end do
- call assert(is_control(DEL))
+ call assert(is_control(ascii_control_char%DEL))
clist = digits//letters//' '
do i = 1, len(clist)
@@ -339,8 +341,8 @@ subroutine test_is_punctuation_short
call assert(.not. is_punctuation('1'))
call assert(.not. is_punctuation('a'))
call assert(.not. is_punctuation(' '))
- call assert(.not. is_punctuation(LF)) ! new line character
- call assert(.not. is_punctuation(NUL))
+ call assert(.not. is_punctuation(ascii_control_char%LF)) ! new line character
+ call assert(.not. is_punctuation(ascii_control_char%NUL))
! N.B.: Non-ASCII Unicode punctuation characters are not recognized.
! write(*,*) is_punctuation('\u2012') ! (U+2012 = en-dash)
@@ -366,8 +368,8 @@ subroutine test_is_graphical_short
call assert(is_graphical('a'))
call assert(is_graphical('#'))
call assert(.not. is_graphical(' ')) ! whitespace is not graphical
- call assert(.not. is_graphical(LF))
- call assert(.not. is_graphical(NUL))
+ call assert(.not. is_graphical(ascii_control_char%LF))
+ call assert(.not. is_graphical(ascii_control_char%NUL))
! N.B.: Unicode graphical characters are not regarded as such.
call assert(.not. is_graphical('ä'))
@@ -393,7 +395,7 @@ subroutine test_is_printable_short
call assert(is_printable('1'))
call assert(is_printable('a'))
call assert(is_printable('#'))
- call assert(.not. is_printable(NUL)) ! control characters are not printable
+ call assert(.not. is_printable(ascii_control_char%NUL)) ! control characters are not printable
! N.B.: Printable non-ASCII Unicode characters are not recognized.
call assert(.not. is_printable('ä'))
@@ -478,65 +480,126 @@ subroutine test_to_upper_long()
end do
end subroutine
- !
- ! This test reproduces the true/false table found at
- ! https://en.cppreference.com/w/cpp/string/byte
- !
+
+!> This test reproduces the true/false table found at
+! https://en.cppreference.com/w/cpp/string/byte
+! by passing allocatable character arrays filled with subsets
+! of ascii characters to the stdlib character validation functions.
+!
subroutine test_ascii_table
integer :: i, j
- character(len=1) :: c
logical :: table(15,12)
+ character(len=7) :: col
+
+ character(len=1), allocatable :: ca(:)
+ integer :: ic(16) ! 15 + 1
+
+ write(*,*) "test_ascii_table"
+
+ ! 0-8 control codes
+ ! 9 tab
+ ! 10-13 whitespaces
+ ! 14-31 control codes
+ ! 32 space
+ ! 33-47 !"#$%&'()*+,-./
+ ! 48-57 0123456789
+ ! 58-64 :;<=>?@
+ ! 65-70 ABCDEF
+ ! 71-90 GHIJKLMNOPQRSTUVWXYZ
+ ! 91-96 [\]^_`
+ ! 97-102 abcdef
+ ! 103-122 ghijklmnopqrstuvwxyz
+ ! 123-126 {|}~
+ ! 127 backspace character
+
+ ic = [0,9,10,14,32,33,48,58,65,71,91,97,103,123,127,128]
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,1) = all(is_control(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,2) = all(is_printable(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,3) = all(is_white(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,4) = all(is_blank(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,5) = all(is_graphical(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,6) = all(is_punctuation(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,7) = all(is_alphanum(ca))
+ end do
- abstract interface
- pure logical function validation_func_interface(c)
- character(len=1), intent(in) :: c
- end function
- end interface
-
- type :: proc_pointer_array
- procedure(validation_func_interface), pointer, nopass :: pcf
- end type proc_pointer_array
-
- type(proc_pointer_array) :: pcfs(12)
-
- pcfs(1)%pcf => is_control
- pcfs(2)%pcf => is_printable
- pcfs(3)%pcf => is_white
- pcfs(4)%pcf => is_blank
- pcfs(5)%pcf => is_graphical
- pcfs(6)%pcf => is_punctuation
- pcfs(7)%pcf => is_alphanum
- pcfs(8)%pcf => is_alpha
- pcfs(9)%pcf => is_upper
- pcfs(10)%pcf => is_lower
- pcfs(11)%pcf => is_digit
- pcfs(12)%pcf => is_hex_digit
-
- ! loop through functions
- do i = 1, 12
- table(1,i) = all([(pcfs(i)%pcf(achar(j)),j=0,8)]) ! control codes
- table(2,i) = pcfs(i)%pcf(achar(9)) ! tab
- table(3,i) = all([(pcfs(i)%pcf(achar(j)),j=10,13)]) ! whitespaces
- table(4,i) = all([(pcfs(i)%pcf(achar(j)),j=14,31)]) ! control codes
- table(5,i) = pcfs(i)%pcf(achar(32)) ! space
- table(6,i) = all([(pcfs(i)%pcf(achar(j)),j=33,47)]) ! !"#$%&'()*+,-./
- table(7,i) = all([(pcfs(i)%pcf(achar(j)),j=48,57)]) ! 0123456789
- table(8,i) = all([(pcfs(i)%pcf(achar(j)),j=58,64)]) ! :;<=>?@
- table(9,i) = all([(pcfs(i)%pcf(achar(j)),j=65,70)]) ! ABCDEF
- table(10,i) = all([(pcfs(i)%pcf(achar(j)),j=71,90)]) ! GHIJKLMNOPQRSTUVWXYZ
- table(11,i) = all([(pcfs(i)%pcf(achar(j)),j=91,96)]) ! [\]^_`
- table(12,i) = all([(pcfs(i)%pcf(achar(j)),j=97,102)]) ! abcdef
- table(13,i) = all([(pcfs(i)%pcf(achar(j)),j=103,122)]) ! ghijklmnopqrstuvwxyz
- table(14,i) = all([(pcfs(i)%pcf(achar(j)),j=123,126)]) ! {|}~
- table(15,i) = pcfs(i)%pcf(achar(127)) ! backspace character
- end do
-
- ! output table for verification
- write(*,'(5X,12(I4))') (i,i=1,12)
- do j = 1, 15
- write(*,'(I3,2X,12(L4),2X,I3)') j, (table(j,i),i=1,12), count(table(j,:))
- end do
- write(*,'(5X,12(I4))') (count(table(:,i)),i=1,12)
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,8) = all(is_alpha(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,9) = all(is_upper(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,10) = all(is_lower(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,11) = all(is_digit(ca))
+ end do
+
+ do i = 1, 15
+ ca = [(achar(j),j=ic(i),ic(i+1)-1)]
+ table(i,12) = all(is_hex_digit(ca))
+ end do
+
+
+ ! Output true/false table for verification
+ write(*,*)
+ write(*,'(10X,A)') "is_control"
+ write(*,'(10X,A)') "| is_printable"
+ write(*,'(10X,A)') "| | is_whitespace"
+ write(*,'(10X,A)') "| | | is_blank"
+ write(*,'(10X,A)') "| | | | is_graphical"
+ write(*,'(10X,A)') "| | | | | is_punctuation"
+ write(*,'(10X,A)') "| | | | | | is_alphanum"
+ write(*,'(10X,A)') "| | | | | | | is_alpha"
+ write(*,'(10X,A)') "| | | | | | | | is_upper"
+ write(*,'(10X,A)') "| | | | | | | | | is_lower"
+ write(*,'(10X,A)') "| | | | | | | | | | is_digit"
+ write(*,'(A10,A)') " decimal ","| | | | | | | | | | | is_hex_digit"
+ write(*,*) "-------------------------------------------"
+ do i = 1, 15
+ ! Process first column
+ if (ic(i) /= ic(i+1)-1) then
+ write(col,'(I0,"-",I0)') ic(i), ic(i+1)-1
+ else
+ write(col,'(I0)') ic(i)
+ end if
+
+ write(*,'(1X,A7,2X,12(L1,:,X),2X,I3)') adjustr(col), (table(i,j),j=1,12)
+ end do
end subroutine
end program
\ No newline at end of file