Commit | Line | Data |
---|---|---|
3666a048 | 1 | ! Copyright 2018-2021 Free Software Foundation, Inc. |
23be8da7 RB |
2 | ! |
3 | ! This program is free software; you can redistribute it and/or modify | |
4 | ! it under the terms of the GNU General Public License as published by | |
5 | ! the Free Software Foundation; either version 3 of the License, or | |
6 | ! (at your option) any later version. | |
7 | ! | |
8 | ! This program is distributed in the hope that it will be useful, | |
9 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ! GNU General Public License for more details. | |
12 | ! | |
13 | ! You should have received a copy of the GNU General Public License | |
14 | ! along with this program. If not, see <http://www.gnu.org/licenses/> . | |
15 | ||
16 | ! Source code for short-circuit-argument-list.exp. | |
17 | ||
7b63ad86 RB |
18 | module called_state |
19 | implicit none | |
20 | type called_counts | |
21 | integer :: function_no_arg_called = 0 | |
22 | integer :: function_no_arg_false_called = 0 | |
23 | integer :: function_one_arg_called = 0 | |
24 | integer :: function_two_arg_called = 0 | |
25 | integer :: function_array_called = 0 | |
26 | end type | |
27 | type(called_counts) :: calls | |
28 | end module called_state | |
29 | ||
23be8da7 | 30 | logical function function_no_arg() |
7b63ad86 RB |
31 | use called_state |
32 | implicit none | |
33 | calls%function_no_arg_called = calls%function_no_arg_called + 1 | |
23be8da7 RB |
34 | function_no_arg = .TRUE. |
35 | end function function_no_arg | |
36 | ||
37 | logical function function_no_arg_false() | |
7b63ad86 RB |
38 | use called_state |
39 | implicit none | |
40 | calls%function_no_arg_false_called = calls%function_no_arg_false_called + 1 | |
23be8da7 RB |
41 | function_no_arg_false = .FALSE. |
42 | end function function_no_arg_false | |
43 | ||
44 | logical function function_one_arg(x) | |
7b63ad86 RB |
45 | use called_state |
46 | implicit none | |
23be8da7 | 47 | logical, intent(in) :: x |
7b63ad86 | 48 | calls%function_one_arg_called = calls%function_one_arg_called + 1 |
23be8da7 RB |
49 | function_one_arg = .TRUE. |
50 | end function function_one_arg | |
51 | ||
52 | logical function function_two_arg(x, y) | |
7b63ad86 RB |
53 | use called_state |
54 | implicit none | |
23be8da7 | 55 | logical, intent(in) :: x, y |
7b63ad86 | 56 | calls%function_two_arg_called = calls%function_two_arg_called + 1 |
23be8da7 RB |
57 | function_two_arg = .TRUE. |
58 | end function function_two_arg | |
59 | ||
60 | logical function function_array(logical_array) | |
7b63ad86 RB |
61 | use called_state |
62 | implicit none | |
23be8da7 RB |
63 | logical, dimension(4,2), target, intent(in) :: logical_array |
64 | logical, dimension(:,:), pointer :: p | |
7b63ad86 | 65 | calls%function_array_called = calls%function_array_called + 1 |
23be8da7 RB |
66 | function_array = .TRUE. |
67 | end function function_array | |
68 | ||
69 | program generate_truth_table | |
7b63ad86 | 70 | use called_state |
23be8da7 RB |
71 | implicit none |
72 | interface | |
73 | logical function function_no_arg() | |
74 | end function function_no_arg | |
75 | logical function function_no_arg_false() | |
76 | end function | |
77 | logical function function_one_arg(x) | |
78 | logical, intent(in) :: x | |
79 | end function | |
80 | logical function function_two_arg(x, y) | |
81 | logical, intent(in) :: x, y | |
82 | end function | |
83 | logical function function_array(logical_array) | |
84 | logical, dimension(4,2), target, intent(in) :: logical_array | |
85 | end function function_array | |
86 | end interface | |
87 | logical, dimension (4,2) :: truth_table | |
88 | logical :: a, b, c, d, e | |
89 | character(2) :: binary_string | |
90 | binary_string = char(0) // char(1) | |
91 | truth_table = .FALSE. | |
92 | truth_table(3:4,1) = .TRUE. | |
93 | truth_table(2::2,2) = .TRUE. | |
94 | a = function_no_arg() ! post_truth_table_init | |
95 | b = function_no_arg_false() | |
96 | c = function_one_arg(b) | |
97 | d = function_two_arg(a, b) | |
98 | e = function_array(truth_table) | |
99 | print *, truth_table(:, 1), a, b, e | |
100 | print *, truth_table(:, 2), c, d | |
101 | end program generate_truth_table |