| 1 | #include <stdio.h> |
|---|
| 2 | #include <stdlib.h> |
|---|
| 3 | #include <sys/types.h> |
|---|
| 4 | #include <dirent.h> |
|---|
| 5 | #include <sys/wait.h> |
|---|
| 6 | #include <string.h> |
|---|
| 7 | |
|---|
| 8 | #define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) ) |
|---|
| 9 | #define COMPARE2(A,B) ( ! strcmp ( A , B ) ) |
|---|
| 10 | #define INLINELEN (4*8192) |
|---|
| 11 | #define VARLEN 128 |
|---|
| 12 | #define MAXARGS (4*8192) |
|---|
| 13 | |
|---|
| 14 | |
|---|
| 15 | #define DBDIR "tools/code_dbase" |
|---|
| 16 | |
|---|
| 17 | int sw_all = 0 ; |
|---|
| 18 | |
|---|
| 19 | |
|---|
| 20 | main( int argc, char *argv[] ) |
|---|
| 21 | { |
|---|
| 22 | FILE *fp ; |
|---|
| 23 | FILE *calls ; |
|---|
| 24 | char fname[VARLEN], syscom[VARLEN] ; |
|---|
| 25 | char *rout , *vname ; |
|---|
| 26 | if ( argc < 2 || argc > 5 || ( argc == 2 && ! COMPARE2( argv[1] , "rebuild" ) ) ) { |
|---|
| 27 | printf("usage : wrfvar varname routinename\n" ) ; |
|---|
| 28 | printf(" wrfvar rebuild\n" ) ; |
|---|
| 29 | exit(2) ; |
|---|
| 30 | } |
|---|
| 31 | vname = argv[1] ; |
|---|
| 32 | rout = argv[2] ; |
|---|
| 33 | if ( argc == 4 && argv[3] != NULL ) { |
|---|
| 34 | if ( COMPARE2( argv[3] , "all" ) ) sw_all = 1 ; |
|---|
| 35 | } |
|---|
| 36 | sprintf( fname, "%s/calls", DBDIR ) ; |
|---|
| 37 | if (( fp = fopen ( fname , "r" )) == NULL || COMPARE2( argv[1], "rebuild" ) ) { |
|---|
| 38 | int rc ; |
|---|
| 39 | printf("Building code database ... please wait\n") ; |
|---|
| 40 | sprintf( syscom, "cd tools/CodeBase ; make" ) ; |
|---|
| 41 | rc = system( syscom ) ; |
|---|
| 42 | if ( WEXITSTATUS( rc ) ) { exit(3) ; } |
|---|
| 43 | sprintf( syscom, "tools/build_codebase" ) ; |
|---|
| 44 | rc = system( syscom ) ; |
|---|
| 45 | if ( WEXITSTATUS( rc ) ) { exit(3) ; } |
|---|
| 46 | sprintf( syscom, "ln -sf tools/wrfvar ." ) ; |
|---|
| 47 | sprintf( syscom, "ln -sf tools/subinfo ." ) ; |
|---|
| 48 | if ( COMPARE2( argv[1] , "rebuild" ) ) exit ; |
|---|
| 49 | } |
|---|
| 50 | fclose( fp ) ; |
|---|
| 51 | lower_case_str ( vname ) ; |
|---|
| 52 | lower_case_str ( rout ) ; |
|---|
| 53 | printf("<h4>Trace upwards through call tree for %s</h4><p>\n",vname ) ; |
|---|
| 54 | wrfvar ( vname, rout, 0 ) ; |
|---|
| 55 | } |
|---|
| 56 | |
|---|
| 57 | wrfvar ( char * vname, char *rout, int recursion_level ) |
|---|
| 58 | { |
|---|
| 59 | FILE *ROUT ; |
|---|
| 60 | FILE *BBB ; |
|---|
| 61 | FILE *ELEF ; |
|---|
| 62 | FILE *CALLER ; |
|---|
| 63 | FILE *CALLERS ; |
|---|
| 64 | FILE *REGISTRY ; |
|---|
| 65 | DIR *dir ; |
|---|
| 66 | char inln[INLINELEN], inln2[INLINELEN], inln3[INLINELEN] ; |
|---|
| 67 | int i ; |
|---|
| 68 | char fname[VARLEN], fname2[VARLEN], sf[VARLEN] ; |
|---|
| 69 | char vv[VARLEN], vv2[VARLEN] ; |
|---|
| 70 | char u0[VARLEN] , u1[VARLEN] , u2[VARLEN] ; |
|---|
| 71 | char v0[VARLEN] , v1[VARLEN] , v2[VARLEN] ; |
|---|
| 72 | char r[12][VARLEN], t[12][VARLEN], u[12][VARLEN], v[12][VARLEN] ; |
|---|
| 73 | char routfile[VARLEN] ; |
|---|
| 74 | char tmp[VARLEN], darg[VARLEN], dintent[VARLEN] ; |
|---|
| 75 | char hamuna[VARLEN] ; |
|---|
| 76 | char rout1[VARLEN], rout2[VARLEN], rout3[VARLEN] ; |
|---|
| 77 | char sourcefile[VARLEN], sourcefile_caller[VARLEN] ; |
|---|
| 78 | char s1[VARLEN], s2[VARLEN], s3[VARLEN] ; |
|---|
| 79 | char * p, * q, * q1, prev ; |
|---|
| 80 | int found_var, nargs_rout, argn, callno, more_calls, first_time ; |
|---|
| 81 | int contains_i1_declarations ; |
|---|
| 82 | |
|---|
| 83 | if (( dir = opendir ( DBDIR )) == NULL ) { |
|---|
| 84 | fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ; |
|---|
| 85 | } closedir( dir ) ; |
|---|
| 86 | |
|---|
| 87 | strcpy( rout1, rout ) ; |
|---|
| 88 | strcpy( vv, vname ) ; |
|---|
| 89 | strcpy( vv2, vname ) ; |
|---|
| 90 | remove_whitespace( vv2 ) ; |
|---|
| 91 | /* remove arguments */ |
|---|
| 92 | if ((q = strchr( vv2 , '(' )) != NULL ) *q = '\0' ; |
|---|
| 93 | /* remove time level if there */ |
|---|
| 94 | if (( q = strrchr( vv2, '_' )) != NULL ) { |
|---|
| 95 | if ( COMPARE2( q , "_1" ) || COMPARE2( q , "_2" ) || COMPARE2( q , "_3" ) ) *q = '\0' ; |
|---|
| 96 | } |
|---|
| 97 | if ( COMPARE( vv2, "grid%" ) || !strcmp( rout, "registry_i1" )) { |
|---|
| 98 | if (( REGISTRY = fopen( "Registry/Registry" , "r" )) == NULL ) { |
|---|
| 99 | fprintf(stderr,"can not open Registry/Registry\n") ; exit(2) ; } |
|---|
| 100 | strcpy( inln, "" ) ; |
|---|
| 101 | while ( fgets( inln2, INLINELEN, REGISTRY ) != NULL ) { |
|---|
| 102 | int inquote ; |
|---|
| 103 | strcat( inln, inln2 ) ; |
|---|
| 104 | if (( q = strrchr ( inln, '\\' )) != NULL ) { /* continuation */ |
|---|
| 105 | *q = '\0' ; continue ; |
|---|
| 106 | } |
|---|
| 107 | if (( q = strchr( inln, '#' )) != NULL ) *q = '\0' ; |
|---|
| 108 | inquote = 0 ; |
|---|
| 109 | for ( p = inln, q = inln2 ; *p ; p++, q++ ) { |
|---|
| 110 | if ( ! inquote && *p == '"' ) { inquote = 1 ; *p = ' ' ; } |
|---|
| 111 | else if ( inquote && *p == '"' ) { inquote = 0 ; *p = ' ' ; } |
|---|
| 112 | if ( *p == ' ' && inquote ) { *q = '`' ; } |
|---|
| 113 | else { *q = *p ; } |
|---|
| 114 | } |
|---|
| 115 | *q = '\0' ; |
|---|
| 116 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 117 | strcpy( r[i] , "" ) ; |
|---|
| 118 | get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; |
|---|
| 119 | if ( i < 10 ) lower_case_str( r[i] ) ; |
|---|
| 120 | } |
|---|
| 121 | if ( COMPARE2 ( r[0], "state" ) ) { |
|---|
| 122 | if ( COMPARE ( r[4], "dyn_" ) ) { |
|---|
| 123 | /* if core associated */ |
|---|
| 124 | sprintf(s1,"%s_",&(r[4][4])) ; |
|---|
| 125 | i = strlen(&(r[4][4])) ; |
|---|
| 126 | #if 1 |
|---|
| 127 | { char *x , *y ; int j ; |
|---|
| 128 | for ( x = vv2+5 , y = s3 , j = 0 ; j < i ; j++ ) { *y++ = *x++ ; } |
|---|
| 129 | *y = '\0' ; |
|---|
| 130 | } |
|---|
| 131 | #else |
|---|
| 132 | /* is there a bug in this?? */ |
|---|
| 133 | strncpy( s3, vv2+5, i ) ; |
|---|
| 134 | fprintf(stderr,"X %s <- %s %d\n", s3, vv2, i ) ; |
|---|
| 135 | #endif |
|---|
| 136 | sprintf(s2,"%s_",s3) ; |
|---|
| 137 | if ( COMPARE2 ( s1, s2 ) && |
|---|
| 138 | COMPARE2 ( vv2+5+(strlen(r[4])-3), r[2] ) ) { |
|---|
| 139 | for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 140 | for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 141 | printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n", |
|---|
| 142 | recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; |
|---|
| 143 | } |
|---|
| 144 | } else { |
|---|
| 145 | /* if not core associated */ |
|---|
| 146 | if ( COMPARE2 ( vv2+5, r[2] ) ) { |
|---|
| 147 | for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 148 | for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 149 | printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n", |
|---|
| 150 | recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; |
|---|
| 151 | } |
|---|
| 152 | } |
|---|
| 153 | } else if ( COMPARE2 ( r[0], "rconfig" ) ) { |
|---|
| 154 | if ( COMPARE2 ( vv2+5, r[2] ) ) { |
|---|
| 155 | for (p = r[8] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 156 | printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <br>\n", |
|---|
| 157 | recursion_level+1, r[0], r[1], r[2], r[8] ) ; |
|---|
| 158 | } |
|---|
| 159 | } else if ( COMPARE2 ( r[0], "i1" ) && !strcmp( rout, "registry_i1" )) { |
|---|
| 160 | if ( COMPARE2 ( vv2, r[2] ) ) { |
|---|
| 161 | for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 162 | for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } |
|---|
| 163 | printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n", |
|---|
| 164 | recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; |
|---|
| 165 | } |
|---|
| 166 | } |
|---|
| 167 | |
|---|
| 168 | strcpy( inln, "" ) ; |
|---|
| 169 | } |
|---|
| 170 | fclose( REGISTRY ) ; |
|---|
| 171 | return ; |
|---|
| 172 | } |
|---|
| 173 | |
|---|
| 174 | sprintf( routfile, "%s/%s", DBDIR, rout ) ; |
|---|
| 175 | strcpy ( sourcefile , "" ) ; |
|---|
| 176 | found_var = 0 ; |
|---|
| 177 | nargs_rout = 0 ; |
|---|
| 178 | if (( ROUT = fopen( routfile, "r" )) == NULL ) return ; |
|---|
| 179 | { |
|---|
| 180 | contains_i1_declarations = 0 ; |
|---|
| 181 | while ( fgets( inln, INLINELEN, ROUT ) != NULL ) { |
|---|
| 182 | remove_nl ( inln ) ; |
|---|
| 183 | /* find first non space */ |
|---|
| 184 | for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; } |
|---|
| 185 | /* change multiple spaces to single space */ |
|---|
| 186 | for ( q = p, q1 = q , prev = *p ; *q ; q++ ) |
|---|
| 187 | { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } |
|---|
| 188 | strcpy( inln, p ) ; |
|---|
| 189 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 190 | strcpy( t[i] , "" ) ; |
|---|
| 191 | get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; |
|---|
| 192 | } |
|---|
| 193 | if ( COMPARE2( "contains_i1_declarations", t[0] ) ) { |
|---|
| 194 | contains_i1_declarations = 1 ; |
|---|
| 195 | } else if ( COMPARE2( "sourcefile" , t[0] ) ) { |
|---|
| 196 | strcpy ( sourcefile , t[1] ) ; |
|---|
| 197 | } else if ( COMPARE2( "arg" , t[0] ) ) { |
|---|
| 198 | nargs_rout ++ ; |
|---|
| 199 | if ( COMPARE2( t[3] , vname ) && ! COMPARE2( t[9] , "registry" ) ) { |
|---|
| 200 | argn = atoi( t[1] ) ; |
|---|
| 201 | printf("%3d. <b>%s</b> is dummy arg %d of %s (%s);\n", recursion_level+1, vname, argn+1, rout, sourcefile ) ; |
|---|
| 202 | found_var = 1 ; |
|---|
| 203 | fclose( ROUT ) ; |
|---|
| 204 | sprintf(fname,"%s/calls", DBDIR ) ; |
|---|
| 205 | strcpy( rout2, rout ) ; |
|---|
| 206 | if (( CALLERS = fopen( fname , "r" )) == NULL ) return ; |
|---|
| 207 | while ( fgets( inln2, INLINELEN, CALLERS ) != NULL ) { |
|---|
| 208 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 209 | strcpy( u[i] , "" ) ; |
|---|
| 210 | get_token_n( inln2, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ; |
|---|
| 211 | } |
|---|
| 212 | if ( COMPARE2( u[2], rout2 ) ) { |
|---|
| 213 | strcpy( rout , u[0] ) ; |
|---|
| 214 | sprintf( fname, "%s/%s", DBDIR, rout ) ; |
|---|
| 215 | if (( ROUT = fopen( fname, "r" )) == NULL ) return ; |
|---|
| 216 | strcpy ( sourcefile_caller, "" ) ; |
|---|
| 217 | callno = 1 ; |
|---|
| 218 | more_calls = 0 ; |
|---|
| 219 | while ( fgets( inln3, INLINELEN, ROUT ) != NULL ) { |
|---|
| 220 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 221 | strcpy( v[i] , "" ) ; |
|---|
| 222 | get_token_n( inln3, " ", i , v[i] ) ; remove_nl(v[i]) ; lower_case_str( v[i] ) ; |
|---|
| 223 | } |
|---|
| 224 | if ( COMPARE2( v[0] , "sourcefile" ) ) { |
|---|
| 225 | strcpy( sourcefile_caller, v[1] ) ; |
|---|
| 226 | } else if ( COMPARE2( v[0] , "actarg") && ( COMPARE2( v[4] , rout2 ) && atoi( v[1] ) == argn )) { |
|---|
| 227 | if ( callno == 1 || sw_all ) { |
|---|
| 228 | printf(" corresponding actual arg is <b>%s</b>, arg number %d in call %d by %s (%s).<br>\n", |
|---|
| 229 | v[6],argn,callno,rout2,sourcefile_caller) ; |
|---|
| 230 | /* RECURSION */ |
|---|
| 231 | wrfvar ( v[6], rout, recursion_level+1 ) ; |
|---|
| 232 | } else if ( callno >= 2 ) { |
|---|
| 233 | more_calls = callno ; |
|---|
| 234 | } |
|---|
| 235 | callno++ ; |
|---|
| 236 | } |
|---|
| 237 | } |
|---|
| 238 | fclose( ROUT ) ; |
|---|
| 239 | if ( more_calls > 1 && recursion_level == 0 ) { |
|---|
| 240 | printf(" there are %d more calls to %s from %s. Try 'wrfvar %s %s all' to see all.\n", more_calls, rout2, rout, vname, rout2 ) ; |
|---|
| 241 | } |
|---|
| 242 | } |
|---|
| 243 | } |
|---|
| 244 | fclose( CALLERS ) ; |
|---|
| 245 | } else if ( COMPARE2( t[3] , vname ) && COMPARE2( t[9] , "registry" ) ) { |
|---|
| 246 | /* RECURSION */ |
|---|
| 247 | sprintf(tmp, "grid%%s", vname ) ; |
|---|
| 248 | wrfvar ( vname, "registry", recursion_level+1 ) ; |
|---|
| 249 | found_var = 1 ; |
|---|
| 250 | } |
|---|
| 251 | } |
|---|
| 252 | } |
|---|
| 253 | } |
|---|
| 254 | if ( found_var == 0 ) { |
|---|
| 255 | if ( contains_i1_declarations ) { |
|---|
| 256 | /* take a look in the registry for i1 vars that might match */ |
|---|
| 257 | wrfvar ( vname, "registry_i1", recursion_level ) ; /* recursion level does not increase here, since we're checking the registry */ |
|---|
| 258 | } else { |
|---|
| 259 | printf("%s is not an argument to %s. May be local or use-associated.\n",vname,rout1 ) ; |
|---|
| 260 | printf("%s has %d arguments\n",rout1,nargs_rout) ; |
|---|
| 261 | fclose(ROUT) ; |
|---|
| 262 | if (( ROUT = fopen( routfile , "r" )) == NULL ) return ; |
|---|
| 263 | while ( fgets( inln2, INLINELEN, ROUT ) != NULL ) { |
|---|
| 264 | remove_nl( inln2 ) ; |
|---|
| 265 | /* find first non space */ |
|---|
| 266 | for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; } |
|---|
| 267 | /* change multiple spaces to single space */ |
|---|
| 268 | for ( q = p, q1 = q , prev = *p ; *q ; q++ ) { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } |
|---|
| 269 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 270 | strcpy( r[i] , "" ) ; |
|---|
| 271 | get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; lower_case_str( r[i] ) ; |
|---|
| 272 | } |
|---|
| 273 | if ( COMPARE2( r[0] , "arg" ) ) { |
|---|
| 274 | i = atoi(r[1]) + 1 ; |
|---|
| 275 | printf("%3d. ",i) ; |
|---|
| 276 | printf("%s of type %s intent %s\n",r[3],r[5],r[7]) ; |
|---|
| 277 | } |
|---|
| 278 | } |
|---|
| 279 | fclose( ROUT ) ; |
|---|
| 280 | } |
|---|
| 281 | } |
|---|
| 282 | |
|---|
| 283 | /* get a list of the routines this guy calls */ |
|---|
| 284 | |
|---|
| 285 | if ( recursion_level == 0 ) { |
|---|
| 286 | first_time = 1 ; |
|---|
| 287 | if (( BBB = fopen( routfile, "r" )) == NULL ) return ; |
|---|
| 288 | while ( fgets( inln2, INLINELEN, BBB ) != NULL ) { |
|---|
| 289 | remove_nl( inln2 ) ; |
|---|
| 290 | /* find first non space */ |
|---|
| 291 | for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; } |
|---|
| 292 | /* change multiple spaces to single space */ |
|---|
| 293 | for ( q = p, q1 = q , prev = *p ; *q ; q++ ) |
|---|
| 294 | { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } |
|---|
| 295 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 296 | strcpy( t[i] , "" ) ; |
|---|
| 297 | get_token_n( inln2, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; |
|---|
| 298 | } |
|---|
| 299 | if ( COMPARE2( t[0] , rout1 ) && COMPARE2( t[1] , "calls" ) ) { |
|---|
| 300 | strcpy( hamuna , t[2] ) ; |
|---|
| 301 | } else if ( COMPARE2( t[0] , "actarg" ) && COMPARE2( t[6] , vname ) ) { |
|---|
| 302 | if ( first_time ) { |
|---|
| 303 | printf("\n<h4>%s is an actual arg in calls to these routines from %s</h4>\n",vname,rout1) ; |
|---|
| 304 | first_time = 0 ; |
|---|
| 305 | } |
|---|
| 306 | sprintf(fname,"%s/%s",DBDIR,hamuna) ; |
|---|
| 307 | if (( ELEF = fopen ( fname , "r" )) == NULL ) continue ; |
|---|
| 308 | while ( fgets( inln3, INLINELEN, ELEF ) != NULL ) { |
|---|
| 309 | remove_nl( inln3 ) ; |
|---|
| 310 | /* find first non space */ |
|---|
| 311 | for ( p = inln3 ; *p ; p++ ) { if ( *p != ' ' ) break ; } |
|---|
| 312 | /* change multiple spaces to single space */ |
|---|
| 313 | for ( q = p, q1 = q , prev = *p ; *q ; q++ ) |
|---|
| 314 | { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } |
|---|
| 315 | for ( i = 0 ; i < 11 ; i++ ) { |
|---|
| 316 | strcpy( u[i] , "" ) ; |
|---|
| 317 | get_token_n( inln3, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ; |
|---|
| 318 | } |
|---|
| 319 | if ( COMPARE2( u[0] , "arg" ) && COMPARE2( u[1] , t[1] ) ) { |
|---|
| 320 | strcpy( darg , u[3] ) ; |
|---|
| 321 | strcpy( dintent , u[7] ) ; |
|---|
| 322 | break ; |
|---|
| 323 | } |
|---|
| 324 | } |
|---|
| 325 | fclose( ELEF ) ; |
|---|
| 326 | printf(" %s (argument %d ; matching dummy arg is %s with intent %s)\n",hamuna,atoi(t[1])+1,darg,dintent ) ; |
|---|
| 327 | } |
|---|
| 328 | } |
|---|
| 329 | printf("\n") ; |
|---|
| 330 | fclose(BBB) ; |
|---|
| 331 | } |
|---|
| 332 | } |
|---|
| 333 | |
|---|
| 334 | |
|---|
| 335 | |
|---|
| 336 | #if 0 |
|---|
| 337 | #!/bin/perl |
|---|
| 338 | |
|---|
| 339 | $dbdir = "tools/code_dbase" ; |
|---|
| 340 | |
|---|
| 341 | if ( ! opendir( TOOLDIR, "tools") ) { |
|---|
| 342 | print "\nMust be in top level WRF directory\n" ; |
|---|
| 343 | exit ; |
|---|
| 344 | } |
|---|
| 345 | closedir TOOLDIR ; |
|---|
| 346 | |
|---|
| 347 | if ( (scalar @ARGV < 1 || scalar @ARGV > 3) || (scalar @ARGV == 1 && @ARGV[0] ne "rebuild") ) { |
|---|
| 348 | print "usage: wrfvar varname routinename \n" ; |
|---|
| 349 | print " wrfvar rebuild \n" ; |
|---|
| 350 | exit ; |
|---|
| 351 | } |
|---|
| 352 | |
|---|
| 353 | |
|---|
| 354 | if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" ) |
|---|
| 355 | { |
|---|
| 356 | print "Building code database ... please wait.\n" ; |
|---|
| 357 | system( "cd tools/CodeBase ; make" ) ; |
|---|
| 358 | $rc = system( "tools/build_codebase" ) ; |
|---|
| 359 | |
|---|
| 360 | if ( ($rc >> 8) == 99 ) { exit ; } |
|---|
| 361 | system( "ln -sf tools/wrfvar ." ) ; |
|---|
| 362 | system( "ln -sf tools/subinfo ." ) ; |
|---|
| 363 | |
|---|
| 364 | if ( $ARGV[0] eq "rebuild" ) { exit ; } |
|---|
| 365 | } |
|---|
| 366 | |
|---|
| 367 | |
|---|
| 368 | $vname = lc $ARGV[0] ; |
|---|
| 369 | $vname1 = $vname ; |
|---|
| 370 | $rout1 = lc $ARGV[1] ; |
|---|
| 371 | $recursion_level = $ARGV[2] ; |
|---|
| 372 | $rout = $rout1 ; |
|---|
| 373 | #print $vname,"\n" ; |
|---|
| 374 | #print $rout,"\n" ; |
|---|
| 375 | |
|---|
| 376 | $spc = "`" ; |
|---|
| 377 | $vv = $vname ; |
|---|
| 378 | $vv =~ s/\(.*// ; |
|---|
| 379 | #print $vv,"\n" ; |
|---|
| 380 | if ( substr($vv,0,5) eq "grid%" ) { |
|---|
| 381 | open REGISTRY, "< Registry/Registry" or die "cannot open Registry/Registry" ; |
|---|
| 382 | while ( <REGISTRY> ) { |
|---|
| 383 | |
|---|
| 384 | $line = $_ ; |
|---|
| 385 | $line =~ s/#.*// ; |
|---|
| 386 | next if ( $line eq "" ) ; |
|---|
| 387 | $line =~ s/[ \t][ \t]*/ /g ; |
|---|
| 388 | $line = lc $line ; |
|---|
| 389 | # fill in the blanks in quote delimited strings then remove |
|---|
| 390 | # the quotes so we can split on white space |
|---|
| 391 | |
|---|
| 392 | $inquote = 0 ; |
|---|
| 393 | $newline = "" ; |
|---|
| 394 | for ( $i = 0 ; $i < length($line) ; $i++ ) |
|---|
| 395 | { |
|---|
| 396 | $ccc = substr($line,$i,1) ; |
|---|
| 397 | if ( ! $inquote && $ccc eq '"' ) { $inquote = 1 ; } |
|---|
| 398 | elsif ( $inquote && $ccc eq '"' ) { $inquote = 0 ; } |
|---|
| 399 | if ( $ccc eq " " && $inquote ) { $newline = $newline.$spc ; } |
|---|
| 400 | else { $newline = $newline.$ccc ; } |
|---|
| 401 | } |
|---|
| 402 | $line = $newline ; |
|---|
| 403 | $line =~ s/\"//g ; |
|---|
| 404 | |
|---|
| 405 | @r = split ( ' ',$line ) ; |
|---|
| 406 | if ( ($r[0] eq state ) ) { |
|---|
| 407 | if (( substr($r[4],0,4) eq "dyn_" && |
|---|
| 408 | substr($r[4],4,length($r[4])-4)."_" eq substr($vv,5,length($r[4])-4)."_" && |
|---|
| 409 | substr($vv,5+length($r[4])-4+1,length($r[2]))) eq $r[2] ) { |
|---|
| 410 | |
|---|
| 411 | $r[9] =~ s/`/ /g ; |
|---|
| 412 | $r[9] = uc $r[9] ; |
|---|
| 413 | $r[10] =~ s/`/ /g ; |
|---|
| 414 | $r[10] = uc $r[10] ; |
|---|
| 415 | print "** Registry Definition: <class> $r[0] <type> $r[1] <varname> ", uc $r[2]," <decription> \"$r[9]\" <units> \"$r[10]\"\n" |
|---|
| 416 | } |
|---|
| 417 | } |
|---|
| 418 | } |
|---|
| 419 | close REGISTRY ; |
|---|
| 420 | exit ; |
|---|
| 421 | } |
|---|
| 422 | |
|---|
| 423 | $routfile = $dbdir."/".$rout ; |
|---|
| 424 | open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 425 | |
|---|
| 426 | $sourcefile = "" ; |
|---|
| 427 | $found_var = 0 ; |
|---|
| 428 | $nargs_rout = 0 ; |
|---|
| 429 | while ( <ROUT> ) |
|---|
| 430 | { |
|---|
| 431 | s/^ *// ; |
|---|
| 432 | s/ */ /g ; |
|---|
| 433 | @t = split ' ' ; |
|---|
| 434 | if ( $t[0] eq "sourcefile" ) { |
|---|
| 435 | $sourcefile = $t[1] ; |
|---|
| 436 | } elsif ( $t[0] eq "arg" ) { |
|---|
| 437 | $nargs_rout++ ; |
|---|
| 438 | if ( $t[3] eq $vname && $t[9] ne "registry" ) { |
|---|
| 439 | $argn = $t[1] ; |
|---|
| 440 | print " ",uc $vname," is dummy argument $argn of $rout ($sourcefile)\n" ; |
|---|
| 441 | $found_var = 1 ; |
|---|
| 442 | close ROUT ; |
|---|
| 443 | system( "sort -u $dbdir/calls > /tmp/wrfvar-sort ; /bin/mv /tmp/wrfvar-sort $dbdir/calls" ) ; |
|---|
| 444 | open CALLERS, "< $dbdir/calls" ; |
|---|
| 445 | $rout2 = $rout ; |
|---|
| 446 | while ( <CALLERS> ) { |
|---|
| 447 | @u = split ' ' ; |
|---|
| 448 | if ( $u[2] eq $rout2 ) |
|---|
| 449 | { |
|---|
| 450 | $rout = $u[0] ; |
|---|
| 451 | $routfile = $dbdir."/".$rout ; |
|---|
| 452 | open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 453 | $sourcefile_caller = "" ; |
|---|
| 454 | $callno = 1 ; |
|---|
| 455 | while ( <ROUT> ) { |
|---|
| 456 | @v = split ' ' ; |
|---|
| 457 | if ( $v[0] eq "sourcefile" ) { |
|---|
| 458 | $sourcefile_caller = $v[1] ; |
|---|
| 459 | } elsif ( $v[0] eq 'actarg' && $v[4] eq $rout2 && $v[1] eq $argn ) { |
|---|
| 460 | print ucfirst $rout2," call $callno by $rout ($sourcefile_caller) with actual argument $argn: ",uc $v[6],"\n" ; |
|---|
| 461 | $callno++ ; |
|---|
| 462 | $vname = $v[6] ; |
|---|
| 463 | ############## RECURSION ############## |
|---|
| 464 | @sysargs = ( "tools/wrfvar" , $v[6], $rout, $recursion_level+1 ) ; |
|---|
| 465 | system( @sysargs ) ; |
|---|
| 466 | } |
|---|
| 467 | } |
|---|
| 468 | close ( ROUT ) ; |
|---|
| 469 | } |
|---|
| 470 | } |
|---|
| 471 | close ( CALLERS ) ; |
|---|
| 472 | } elsif ( $t[3] eq $vname && $t[9] eq "registry" ) { |
|---|
| 473 | @sysargs = ( "tools/wrfvar" , "grid%".$vname, "registry", $recursion_level+1 ) ; |
|---|
| 474 | ############## RECURSION ############## |
|---|
| 475 | system( @sysargs ) ; |
|---|
| 476 | $found_var = 1 ; |
|---|
| 477 | } |
|---|
| 478 | } |
|---|
| 479 | } |
|---|
| 480 | |
|---|
| 481 | if ( $found_var == 0 ) { |
|---|
| 482 | print uc $vname , " is not an argument to ${rout1}. May be local or use-associated.\n" ; |
|---|
| 483 | print ucfirst $rout1," has $nargs_rout arguments.\n" ; |
|---|
| 484 | close ROUT ; |
|---|
| 485 | open ROUT, "< $routfile" or die "can not open $routfile" ; |
|---|
| 486 | while ( <ROUT> ) |
|---|
| 487 | { |
|---|
| 488 | s/^ *// ; |
|---|
| 489 | s/ */ /g ; |
|---|
| 490 | @t = split ' ' ; |
|---|
| 491 | if ( $t[0] eq "arg" ) { |
|---|
| 492 | $i = $t[1] + 1 ; |
|---|
| 493 | printf("%3d. ",$i) ; |
|---|
| 494 | print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ; |
|---|
| 495 | } |
|---|
| 496 | } |
|---|
| 497 | close ROUT ; |
|---|
| 498 | } |
|---|
| 499 | |
|---|
| 500 | # get a list of the routines this guy calls |
|---|
| 501 | |
|---|
| 502 | if ( $recursion_level == 0 ) { |
|---|
| 503 | $first_time = 1 ; |
|---|
| 504 | open BBB, "< $dbdir/$rout1" or die " cannot open $dbdir/$rout1" ; |
|---|
| 505 | while ( <BBB> ) { |
|---|
| 506 | @t = split ' ' ; |
|---|
| 507 | if ( $t[0] eq "$rout1" && $t[1] eq calls ) { |
|---|
| 508 | $hamuna = $t[2] ; |
|---|
| 509 | } elsif ( $t[0] eq "actarg" && $t[6] eq $vname1 ) { |
|---|
| 510 | if ( $first_time == 1 ) { |
|---|
| 511 | print "\n",uc $vname1," is an actual argument in calls to these routines from ",uc $rout1," :\n" ; |
|---|
| 512 | $first_time = 0 ; |
|---|
| 513 | } |
|---|
| 514 | open ELEF,"< $dbdir/$hamuna" or die "cannot open $dbdir/$hamuna" ; |
|---|
| 515 | while ( <ELEF> ) { |
|---|
| 516 | @u = split ' ' ; |
|---|
| 517 | if ( $u[0] eq arg && $u[1] eq $t[1] ) { |
|---|
| 518 | $darg = $u[3] ; |
|---|
| 519 | $dintent = $u[7] ; |
|---|
| 520 | } |
|---|
| 521 | } |
|---|
| 522 | close ELEF ; |
|---|
| 523 | print " ", $hamuna," (argument ",$t[1]+1," ; matching dummy arg is ",uc $darg," with intent ",uc $dintent,") \n" ; |
|---|
| 524 | } |
|---|
| 525 | } |
|---|
| 526 | print "\n" ; |
|---|
| 527 | close BBB ; |
|---|
| 528 | } |
|---|
| 529 | exit ; |
|---|
| 530 | |
|---|
| 531 | #endif |
|---|
| 532 | |
|---|
