gdb/testsuite/gdb.fortran/short-circuit-argument-list.f90

   1 ! Copyright 2018-2021 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
  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
  30 logical 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.
  35 end function function_no_arg
  36
  37 logical 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.
  42 end function function_no_arg_false
  43
  44 logical 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.
  50 end function function_one_arg
  51
  52 logical 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.
  58 end function function_two_arg
  59
  60 logical 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.
  67 end function function_array
  68
  69 program 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
 101 end program generate_truth_table