source: trunk/WRF.COMMON/WRFV2/tools/CodeBase/deftab.c @ 2756

Last change on this file since 2756 was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 10.9 KB
Line 
1#include <stdio.h>
2#include <string.h>
3
4#define INLINELEN (4*8192)
5#define VARLEN 128
6#define MAXARGS (4*8192)
7
8#define DIR "tools/code_dbase"
9
10char inln[INLINELEN] ;
11
12#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) )
13#define COMPARE2(A,B) ( ! strcmp ( A , B ) )
14
15char module_name[INLINELEN] ;
16char subprogram_name[INLINELEN] ;
17char in_a[INLINELEN] ;
18char arg[MAXARGS][VARLEN] ;
19char type[MAXARGS][VARLEN] ;
20char from[MAXARGS][VARLEN] ;
21char intent[MAXARGS][VARLEN] ;
22char dimensions[MAXARGS][VARLEN] ;
23char typedefs[MAXARGS][INLINELEN] ;
24int ntypedefs = 0 ;
25char tmp[VARLEN] ;
26char infname[VARLEN] ;
27int  nargs ;
28char function_type[VARLEN] ;
29int contained ;
30
31char *ignore = "rsl" ;
32
33int protex_state ;
34
35set_attributes( char * inln, int nargs, char * typ )
36{
37  int i, j ;
38  char *p, tmp[VARLEN] ;
39  for ( i = 0 ; i < nargs ; i++ )
40  {
41    if ( contains_tok ( inln , arg[i], " ()," ) ) {
42      strcpy( type[i], typ ) ;
43      if (( j = contains_tok ( inln, "intent", " (),:" ))) {
44        get_token_n ( inln , " (),:", j+1, intent[i] ) ;
45      }
46      else
47      {
48        strcpy(intent[i],"inout") ;
49      }
50      strcpy( dimensions[i], "" ) ;
51      if ( find_str ( inln, "dimension", &p )) {
52        j = 0 ;
53        remove_whitespace( p ) ;
54        while ( get_arg_n ( p , j, tmp ) ) {
55          strcat( dimensions[i], tmp ) ;
56          strcat( dimensions[i], "," ) ;
57          j++ ;
58        }
59        if (( p = rindex( dimensions[i], ',' )) != NULL ) *p = '\0' ;
60      }
61    }
62  }
63}
64
65handle_subprogram ( FILE **fp, FILE *ifp, int *nargs, char * sname , char * inln , int tokpos )
66{
67  char fname[VARLEN] ;
68  int i ;
69
70  if ( ! contained ) {
71    sprintf(fname,"%s/%s",DIR, sname ) ;
72    if ((*fp = fopen( fname , "w" )) == NULL ) {
73      fprintf(stderr,"cannot open %s for writing\n",fname) ; exit(1) ;
74    }
75    fprintf(*fp,"sourcefile %s\n",infname ) ;
76    if ( COMPARE( in_a, "function" ) ) {
77      fprintf(*fp,"subprogram %s %s\n",in_a, function_type ) ;
78    } else {
79      fprintf(*fp,"subprogram %s\n",in_a ) ;
80    }
81    for ( i = 0 ; get_token_n ( inln , " (,)", i+tokpos, arg[i] ) ; i++ ) { strcpy( from[i], "dummyarg" ) ; }
82    *nargs = i ;
83    ntypedefs = 0 ;
84    fprintf(*fp,"nargs %d\n", *nargs) ;
85  }
86  contained++ ;
87}
88
89main( int argc, char * argv[] )
90{
91  FILE *infl ;
92  FILE *fp, *fpcalls, *fpdescription ;
93  int i, j ;
94  char callee[VARLEN] ;
95  char fname[VARLEN] ;
96  char description_name[VARLEN] ;
97  char mess[INLINELEN] ;
98  int in_interface ;
99  int looking_scalar_derefs ;
100
101  strcpy( module_name, "" ) ;
102  strcpy( subprogram_name, "" ) ;
103  strcpy( infname, "" ) ;
104
105  infl = stdin ;
106  if ( argc == 2 ) {
107    strcpy( infname, argv[1] ) ;
108  }
109  sprintf(fname,"%s/calls",DIR ) ;
110  if ( ( fpcalls = fopen( fname , "a" )) == NULL )
111  {
112    fprintf(stderr,"cannot open %s\n",fname) ;
113    exit(1) ;
114  }
115
116  in_interface = 0 ;
117
118  looking_scalar_derefs = 0 ;
119 
120  contained = 0 ;
121
122  protex_state = 0 ;
123  fpdescription = NULL ;
124
125  while( fgets( inln, INLINELEN, infl ) != NULL )
126  {
127    if ( protex_state > 0 ) {   /* in a description */
128       if ( contains_str ( inln, "</DESCRIPTION>" ) ) {
129         protex_state = 0 ;
130         if ( fpdescription != NULL ) fclose( fpdescription ) ; 
131         fpdescription = NULL ;
132         continue ;
133       }
134       if ( fpdescription != NULL ) {
135          remove_chars( inln, "!", ' ' ) ;
136          if ( empty( inln ) ) {
137            fprintf(fpdescription,"<p>\n") ;
138          } else {
139            fprintf(fpdescription,"%s",inln) ;
140          }
141          continue ;
142       }
143    }
144    remove_nl ( inln ) ;
145    lower_case_str ( inln ) ;
146    if ( looking_scalar_derefs ) {
147       if ( COMPARE ( inln, "grid%" ) ) {
148         get_token_n ( inln , " ", 2, arg[nargs] ) ;
149         strcpy( from[nargs] , "registry" ) ;
150         nargs++ ;
151       }
152    }
153    if ( in_interface ) {
154       if ( COMPARE( inln , "end interface" ) ) in_interface = 0 ;
155       /* ignore interface blocks */
156       continue ;
157    }
158    if ( COMPARE( inln , "interface" ) ) {
159       in_interface = 1 ;
160    } else if ( COMPARE( inln , "module " ) ) {
161       get_token_n ( inln , " (,", 1, module_name ) ;
162    } else if ( COMPARE( inln , "end module" ) ) {
163       strcpy( module_name, "" ) ;
164    } else if ( COMPARE( inln , "program " ) ) {
165       strcpy(in_a, "program") ;
166       get_token_n ( inln , " (,", 1, subprogram_name ) ;
167       handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ;
168    } else if ( COMPARE( inln , "subroutine " ) ) {
169       strcpy(in_a, "subroutine") ;
170       get_token_n ( inln , " (,", 1, subprogram_name ) ;
171       handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ;
172    } else if ( COMPARE( inln , "function " ) ) {
173       strcpy(in_a, "function") ;
174       get_token_n ( inln , " (,", 1, subprogram_name ) ;
175       handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ;
176    } else if ( COMPARE( inln , "recursive subroutine " ) ) {
177       strcpy(in_a, "recursive subroutine") ;
178       get_token_n ( inln , " (,", 2, subprogram_name ) ;
179       handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 3 ) ;
180    } else if ( contains_str ( inln, "startofregistrygeneratedinclude" ) && contains_str ( inln, "i1_decl.inc" )) {
181       if ( strlen( subprogram_name ) > 0 ) {
182         fprintf(fp, "contains_i1_declarations\n" ) ;
183       }
184    } else if ( contains_str ( inln, "! begin scalar derefs" ) ) {
185       looking_scalar_derefs = 1 ;
186    } else if ( contains_str ( inln, "! end scalar derefs" ) ) {
187       looking_scalar_derefs = 0 ;
188    } else if ( contains_str ( inln, "<description>" ) && protex_state == 0 ) {
189       protex_state = 1 ;
190       sprintf(description_name,"%s/%s_descrip",DIR, subprogram_name ) ;
191       if ((fpdescription = fopen( description_name , "a" )) == NULL ) {
192         fprintf(stderr, "cannot open %s for writing\n", description_name ) ; exit(2) ; 
193       }
194       protex_state = 2 ;
195    } else if ( contains_str ( inln, "</description>" ) ) {
196       protex_state = 0 ;
197       if ( fpdescription != NULL ) fclose( fpdescription ) ; 
198       fpdescription = NULL ;
199    } else if ( COMPARE( inln , "use " ) ) {
200       if ( strlen( subprogram_name ) > 0 ) {
201         get_token_n ( inln , " ", 1, tmp ) ;
202         fprintf(fp, "use %s\n",tmp ) ;
203       }
204    } else if ( COMPARE( inln , "call " ) ) {
205       get_token_n ( inln , " (,", 1, callee ) ;
206       if ( ! contains_str( callee , ignore ) ) {
207         fprintf(fpcalls,"%s calls %s\n",subprogram_name, callee ) ;
208         fprintf(fp,"%s calls %s\n",subprogram_name, callee ) ;
209         for ( i = 0 ; get_arg_n ( inln , i, tmp ) ; i++ ) 
210         { 
211           /* check to see if this is a dummy arg and print that info too */
212           strcpy(mess,"") ;
213           for ( j = 0 ; j < nargs ; j++ )
214           {
215             if ( !strcmp( tmp, arg[j] ) )
216             {
217               sprintf( mess, " ( dummy arg %d, type %s ) ",j,type[j] ) ;
218               break ;
219             }
220           }
221           fprintf(fp,"  actarg %d of callee %s is %s%s\n",i,callee, tmp,mess) ; 
222         }
223       }
224    } else if ( COMPARE( inln , "integer " ) || COMPARE( inln , "real " ) || COMPARE( inln , "logical " ) ) {
225         /* look for function */
226       get_token_n ( inln , " ", 0, function_type ) ;
227       get_token_n ( inln , " ,", 1, tmp ) ;
228       if ( COMPARE( tmp, "function" ) )
229       {
230           strcpy(in_a,"function") ;
231           get_token_n ( inln, " (", 2, subprogram_name ) ;
232           handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 3 ) ;
233       }
234       else if ( strlen( subprogram_name ) > 0 && nargs > 0 ) {
235         strcpy( typedefs[ntypedefs++], inln ) ;
236       }
237    } else if ( COMPARE( inln , "type " ) ) {
238       if ( strlen( subprogram_name ) > 0 && nargs > 0 ) {
239         strcpy( typedefs[ntypedefs++], inln ) ;
240       }
241    } else if ( COMPARE( inln , "end subroutine" ) ) {
242       contained-- ;
243       if ( contained == 0 ) {
244         fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ;
245         for ( i = 0 ; i < ntypedefs ; i++ )
246         {
247           if ( COMPARE( typedefs[i], "type" ) ) {
248             get_token_n ( typedefs[i], ",", 0, tmp ) ;
249             remove_whitespace( tmp ) ;
250           } else {
251             get_token_n ( typedefs[i], " ,", 0, tmp ) ;
252           }
253           set_attributes( typedefs[i], nargs, tmp ) ;
254         }
255         for ( i = 0 ; i < nargs ; i++ )
256         {
257           fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ;
258         }
259         fclose(fp) ; fp = NULL ;
260         strcpy( in_a, "" ) ;
261         strcpy( subprogram_name, "" ) ;
262       }
263    } else if ( COMPARE( inln , "end function" ) ) {
264       contained-- ;
265       if ( contained == 0 ) {
266         fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ;
267         for ( i = 0 ; i < ntypedefs ; i++ )
268         {
269           get_token_n ( typedefs[i], " ,", 0, tmp ) ;
270           set_attributes( typedefs[i], nargs, tmp ) ;
271         }
272         for ( i = 0 ; i < nargs ; i++ )
273         {
274           fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ;
275         }
276         fclose(fp) ; fp = NULL ;
277         strcpy( in_a, "" ) ;
278         strcpy( subprogram_name, "" ) ;
279       }
280    } else if ( COMPARE( inln , "end program" ) ) {
281       contained-- ;
282       if ( contained == 0 ) {
283         fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ;
284         for ( i = 0 ; i < ntypedefs ; i++ )
285         {
286           get_token_n ( typedefs[i], " ,", 0, tmp ) ;
287           set_attributes( typedefs[i], nargs, tmp ) ;
288         }
289         for ( i = 0 ; i < nargs ; i++ )
290         {
291           fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ;
292         }
293         fclose(fp) ; fp = NULL ;
294         strcpy( in_a, "" ) ;
295         strcpy( subprogram_name, "" ) ;
296       }
297#if 1
298    } else if ( COMPARE( inln , "end" ) ) {  /* bare end -- take a chance and hope it's a subroutine */
299       remove_whitespace( inln ) ;   /* make sure it's not an enddo, endif, etc */
300       if ( COMPARE2 (inln , "end" ) ) {
301         contained-- ;
302         if ( contained == 0 ) {
303           fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ;
304           for ( i = 0 ; i < ntypedefs ; i++ )
305           {
306             if ( COMPARE( typedefs[i], "type" ) ) {
307               get_token_n ( typedefs[i], ",", 0, tmp ) ;
308               remove_whitespace( tmp ) ;
309             } else {
310               get_token_n ( typedefs[i], " ,", 0, tmp ) ;
311             }
312             set_attributes( typedefs[i], nargs, tmp ) ;
313           }
314           for ( i = 0 ; i < nargs ; i++ )
315           {
316             fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ;
317           }
318           fclose(fp) ; fp = NULL ;
319           strcpy( in_a, "" ) ;
320           strcpy( subprogram_name, "" ) ;
321         }
322       }
323#endif
324    }
325  }
326  fclose( fpcalls ) ; fpcalls = NULL ;
327}
328
Note: See TracBrowser for help on using the repository browser.