@@ -726,10 +726,66 @@ subroutine test_to_upper_long(error)
726
726
! This test reproduces the true/false table found at
727
727
! https://en.cppreference.com/w/cpp/string/byte
728
728
!
729
+ subroutine ascii_table (table )
730
+ logical , intent (out ) :: table(15 ,12 )
731
+ integer :: i, j
732
+
733
+ ! loop through functions
734
+ do i = 1 , 12
735
+ table(1 ,i) = all ([(validate(j,i), j= 0 ,8 )])
736
+ table(2 ,i) = validate(9 ,i)
737
+ table(3 ,i) = all ([(validate(j,i), j= 10 ,13 )])
738
+ table(4 ,i) = all ([(validate(j,i), j= 14 ,31 )])
739
+ table(5 ,i) = validate(32 ,i)
740
+ table(6 ,i) = all ([(validate(j,i), j= 33 ,47 )])
741
+ table(7 ,i) = all ([(validate(j,i), j= 48 ,57 )])
742
+ table(8 ,i) = all ([(validate(j,i), j= 58 ,64 )])
743
+ table(9 ,i) = all ([(validate(j,i), j= 65 ,70 )])
744
+ table(10 ,i) = all ([(validate(j,i), j= 71 ,90 )])
745
+ table(11 ,i) = all ([(validate(j,i), j= 91 ,96 )])
746
+ table(12 ,i) = all ([(validate(j,i), j= 97 ,102 )])
747
+ table(13 ,i) = all ([(validate(j,i), j= 103 ,122 )])
748
+ table(14 ,i) = all ([(validate(j,i), j= 123 ,126 )])
749
+ table(15 ,i) = validate(127 ,i)
750
+ end do
751
+
752
+ ! output table for verification
753
+ write (* ,' (5X,12(I4))' ) (i,i= 1 ,12 )
754
+ do j = 1 , 15
755
+ write (* ,' (I3,2X,12(L4),2X,I3)' ) j, (table(j,i),i= 1 ,12 ), count (table(j,:))
756
+ end do
757
+ write (* ,' (5X,12(I4))' ) (count (table(:,i)),i= 1 ,12 )
758
+
759
+ contains
760
+
761
+ elemental logical function validate(ascii_code, func)
762
+ integer , intent (in ) :: ascii_code, func
763
+ character (len= 1 ) :: c
764
+
765
+ c = achar (ascii_code)
766
+
767
+ select case (func)
768
+ case (1 ); validate = is_control(c)
769
+ case (2 ); validate = is_printable(c)
770
+ case (3 ); validate = is_white(c)
771
+ case (4 ); validate = is_blank(c)
772
+ case (5 ); validate = is_graphical(c)
773
+ case (6 ); validate = is_punctuation(c)
774
+ case (7 ); validate = is_alphanum(c)
775
+ case (8 ); validate = is_alpha(c)
776
+ case (9 ); validate = is_upper(c)
777
+ case (10 ); validate = is_lower(c)
778
+ case (11 ); validate = is_digit(c)
779
+ case (12 ); validate = is_hex_digit(c)
780
+ case default ; validate = .false.
781
+ end select
782
+ end function validate
783
+
784
+ end subroutine ascii_table
785
+
729
786
subroutine test_ascii_table (error )
730
787
type (error_type), allocatable , intent (out ) :: error
731
- integer :: i, j
732
- logical :: table(15 ,12 )
788
+ logical :: arr(15 , 12 )
733
789
logical , parameter :: ascii_class_table(15 ,12 ) = transpose (reshape ([ &
734
790
! iscntrl isprint isspace isblank isgraph ispunct isalnum isalpha isupper islower isdigit isxdigit
735
791
.true. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , & ! 0–8
@@ -749,44 +805,8 @@ subroutine test_ascii_table(error)
749
805
.true. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. , .false. & ! 127
750
806
], shape= [12 ,15 ]))
751
807
752
- type :: list
753
- character (1 ), allocatable :: chars(:)
754
- end type
755
- type (list) :: tests(15 )
756
-
757
- tests(1 )% chars = [(achar (j),j= 0 ,8 )] ! control codes
758
- tests(2 )% chars = [(achar (j),j= 9 ,9 )] ! tab
759
- tests(3 )% chars = [(achar (j),j= 10 ,13 )] ! whitespaces
760
- tests(4 )% chars = [(achar (j),j= 14 ,31 )] ! control codes
761
- tests(5 )% chars = [(achar (j),j= 32 ,32 )] ! space
762
- tests(6 )% chars = [(achar (j),j= 33 ,47 )] ! !"#$%&'()*+,-./
763
- tests(7 )% chars = [(achar (j),j= 48 ,57 )] ! 0123456789
764
- tests(8 )% chars = [(achar (j),j= 58 ,64 )] ! :;<=>?@
765
- tests(9 )% chars = [(achar (j),j= 65 ,70 )] ! ABCDEF
766
- tests(10 )% chars = [(achar (j),j= 71 ,90 )] ! GHIJKLMNOPQRSTUVWXYZ
767
- tests(11 )% chars = [(achar (j),j= 91 ,96 )] ! [\]^_`
768
- tests(12 )% chars = [(achar (j),j= 97 ,102 )] ! abcdef
769
- tests(13 )% chars = [(achar (j),j= 103 ,122 )]! ghijklmnopqrstuvwxyz
770
- tests(14 )% chars = [(achar (j),j= 123 ,126 )]! {|}~
771
- tests(15 )% chars = [(achar (j),j= 127 ,127 )]! backspace character
772
-
773
- ! loop through functions
774
- do i = 1 , 15
775
- table(i,1 ) = all (is_control(tests(i)% chars))
776
- table(i,2 ) = all (is_printable(tests(i)% chars))
777
- table(i,3 ) = all (is_white(tests(i)% chars))
778
- table(i,4 ) = all (is_blank(tests(i)% chars))
779
- table(i,5 ) = all (is_graphical(tests(i)% chars))
780
- table(i,6 ) = all (is_punctuation(tests(i)% chars))
781
- table(i,7 ) = all (is_alphanum(tests(i)% chars))
782
- table(i,8 ) = all (is_alpha(tests(i)% chars))
783
- table(i,9 ) = all (is_upper(tests(i)% chars))
784
- table(i,10 ) = all (is_lower(tests(i)% chars))
785
- table(i,11 ) = all (is_digit(tests(i)% chars))
786
- table(i,12 ) = all (is_hex_digit(tests(i)% chars))
787
- end do
788
-
789
- call check(error, all (table .eqv. ascii_class_table), " ascii table was not accurately generated" )
808
+ call ascii_table(arr)
809
+ call check(error, all (arr .eqv. ascii_class_table), " ascii table was not accurately generated" )
790
810
791
811
end subroutine test_ascii_table
792
812
0 commit comments