gcc/testsuite/lib/fortran-modules.exp

   1 #   Copyright (C) 2012-2018 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 GCC; see the file COPYING3.  If not see
  15 # <http://www.gnu.org/licenses/>.
  16
  17 # helper to deal with fortran modules
  18
  19 # Remove files for specified Fortran modules.
  20 # This includes both .mod and .smod files.
  21 proc cleanup-modules { modlist } {
  22     global clean
  23     foreach mod [concat $modlist $clean] {
  24         set m [string tolower $mod].mod
  25         verbose "cleanup-module `$m'" 2
  26         if [is_remote host] {
  27             remote_file host delete $m
  28         }
  29         remote_file build delete $m
  30     }
  31     cleanup-submodules $modlist
  32 }
  33
  34 # Remove files for specified Fortran submodules.
  35 proc cleanup-submodules { modlist } {
  36     global clean
  37     foreach mod [concat $modlist $clean] {
  38         set m [string tolower $mod].smod
  39         verbose "cleanup-submodule `$m'" 2
  40         if [is_remote host] {
  41             remote_file host delete $m
  42         }
  43         remote_file build delete $m
  44     }
  45 }
  46
  47 proc keep-modules { modlist } {
  48     global clean
  49     # if the modlist is empty, keep everything
  50     if {[llength $modlist] < 1} {
  51         set clean {}
  52     } else {
  53         set cleansed {}
  54         foreach cl $clean {
  55             if {[lsearch $cl $modlist] < 0} {
  56                 lappend cleansed $cl
  57             }
  58         }
  59         if {[llength $clean] == [llength $cleansed]} {
  60             warning "keep-modules had no effect?! Possible typo in module name."
  61         }
  62         set clean $cleansed
  63     }
  64 }
  65
  66 # collect all module names from a source-file
  67 proc list-module-names { files } {
  68     global clean
  69     set clean {}
  70     foreach file $files {
  71         foreach mod [list-module-names-1 $file] {
  72             if {[lsearch $clean $mod] < 0} {
  73                 lappend clean $mod
  74             }
  75         }
  76     }
  77     return [join $clean " "]
  78 }
  79
  80 proc list-module-names-1 { file } {
  81     set result {}
  82     if {[file isdirectory $file]} {return}
  83     # Find lines containing INCLUDE, MODULE, and SUBMODULE, excluding the lines containing
  84     # MODULE [PURE|(IMPURE\s+)?ELEMENTAL|RECURSIVE] (PROCEDURE|FUNCTION|SUBROUTINE)
  85     set pat {^\s*((#)?\s*include|(sub)?module(?!\s+((pure|(impure\s+)?elemental|recursive)\s+)?(procedure|function|subroutine)[:\s]+))\s*.*}
  86     set tmp [igrep $file $pat line]
  87     if {![string match "" $tmp]} {
  88         foreach i $tmp {
  89             regexp -nocase {(\d+)\s+#?\s*include\s+["']([^"']*)["']} $i dummy lineno include_file
  90             if {[info exists include_file]} {
  91                 set dir [file dirname $file]
  92                 set inc "$dir/$include_file"
  93                 unset include_file
  94                 if {![file readable $inc]} {
  95                     # We do not currently use include path search logic, punt
  96                     continue
  97                 }
  98                 verbose "Line $lineno includes `$inc'" 3
  99                 foreach mod [list-module-names-1 $inc] {
 100                     if {[lsearch $result $mod] < 0} {
 101                         lappend result $mod
 102                     }
 103                 }
 104                 continue
 105             }
 106             regexp -nocase {(\d+)\s+(module|submodule)\s*([^;]*)} $i i lineno keyword mod
 107             if {![info exists mod]} {
 108                 continue
 109             }
 110             # Generates the file name mod_name@submod_name from
 111             # (\s*mod_name[:submod_name]\s*)\s*submod_name\s*[! comment]
 112             regsub {\s*!.*} $mod "" mod
 113             regsub {:[^)]*} $mod "" mod
 114             regsub {\(\s*} $mod "" mod
 115             regsub {\s*\)\s*} $mod "@" mod
 116             verbose "Line $lineno mentions module `$mod'" 3
 117             if {[lsearch $result $mod] < 0} {
 118                 lappend result $mod
 119             }
 120         }
 121     }
 122     return $result
 123 }
 124
 125 # Looks for case insensitive occurrences of a string in a file.
 126 #     return:list of lines that matched or NULL if none match.
 127 #     args:  first arg is the filename,
 128 #            second is the pattern,
 129 #            third are any options.
 130 #     Options: line  - puts line numbers of match in list
 131 #
 132 proc igrep { args } {
 133
 134     set file [lindex $args 0]
 135     set pattern [lindex $args 1]
 136
 137     verbose "Grepping $file for the pattern \"$pattern\"" 3
 138
 139     set argc [llength $args]
 140     if { $argc > 2 } {
 141         for { set i 2 } { $i < $argc } { incr i } {
 142             append options [lindex $args $i]
 143             append options " "
 144         }
 145     } else {
 146         set options ""
 147     }
 148
 149     set i 0
 150     set fd [open $file r]
 151     while { [gets $fd cur_line]>=0 } {
 152         incr i
 153         if {[regexp -nocase -- "$pattern" $cur_line match]} {
 154             if {![string match "" $options]} {
 155                 foreach opt $options {
 156                     switch $opt {
 157                         "line" {
 158                             lappend grep_out [concat $i $match]
 159                         }
 160                     }
 161                 }
 162             } else {
 163                 lappend grep_out $match
 164             }
 165         }
 166     }
 167     close $fd
 168     unset fd
 169     unset i
 170     if {![info exists grep_out]} {
 171         set grep_out ""
 172     }
 173     return $grep_out
 174 }