1! Copyright 2018-2020 Free Software Foundation, Inc.
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
18module 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
28end module called_state
29
30logical function function_no_arg()
31    use called_state
32    implicit none
33    calls%function_no_arg_called = calls%function_no_arg_called + 1
34    function_no_arg = .TRUE.
35end function function_no_arg
36
37logical function function_no_arg_false()
38    use called_state
39    implicit none
40    calls%function_no_arg_false_called = calls%function_no_arg_false_called + 1
41    function_no_arg_false = .FALSE.
42end function function_no_arg_false
43
44logical function function_one_arg(x)
45    use called_state
46    implicit none
47    logical, intent(in) :: x
48    calls%function_one_arg_called = calls%function_one_arg_called + 1
49    function_one_arg = .TRUE.
50end function function_one_arg
51
52logical function function_two_arg(x, y)
53    use called_state
54    implicit none
55    logical, intent(in) :: x, y
56    calls%function_two_arg_called = calls%function_two_arg_called + 1
57    function_two_arg = .TRUE.
58end function function_two_arg
59
60logical function function_array(logical_array)
61    use called_state
62    implicit none
63    logical, dimension(4,2), target, intent(in) :: logical_array
64    logical, dimension(:,:), pointer :: p
65    calls%function_array_called = calls%function_array_called + 1
66    function_array = .TRUE.
67end function function_array
68
69program generate_truth_table
70    use called_state
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
101end program generate_truth_table
102