]>
Commit | Line | Data |
---|---|---|
a945c346 | 1 | # Copyright (C) 2012-2024 Free Software Foundation, Inc. |
28eccf2d BRF |
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. | |
a56ea54a | 20 | # This includes both .mod and .smod files. |
28eccf2d BRF |
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 | } | |
a56ea54a | 31 | cleanup-submodules $modlist |
28eccf2d BRF |
32 | } |
33 | ||
3d5dc929 PT |
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 | ||
28eccf2d BRF |
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 {} | |
82c027e1 DH |
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] | |
28eccf2d BRF |
87 | if {![string match "" $tmp]} { |
88 | foreach i $tmp { | |
82c027e1 | 89 | regexp -nocase {(\d+)\s+#?\s*include\s+["']([^"']*)["']} $i dummy lineno include_file |
28eccf2d BRF |
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]} { | |
0560508e | 95 | # We do not currently use include path search logic, punt |
28eccf2d BRF |
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 | } | |
82c027e1 DH |
106 | regexp -nocase {(\d+)\s+(module|submodule)\s*([^;]*)} $i i lineno keyword mod |
107 | if {![info exists mod]} { | |
28eccf2d BRF |
108 | continue |
109 | } | |
82c027e1 DH |
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 | |
28eccf2d BRF |
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 | } | |
82c027e1 DH |
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 | } |