1#   Copyright (C) 2012-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 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.
21proc 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.
35proc 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
47proc 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
67proc 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
80proc 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#
132proc 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}
175