tools/CodeBase/deftab.c

   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
  10 char inln[INLINELEN] ;
  11
  12 #define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) )
  13 #define COMPARE2(A,B) ( ! strcmp ( A , B ) )
  14
  15 char module_name[INLINELEN] ;
  16 char subprogram_name[INLINELEN] ;
  17 char in_a[INLINELEN] ;
  18 char arg[MAXARGS][VARLEN] ;
  19 char type[MAXARGS][VARLEN] ;
  20 char from[MAXARGS][VARLEN] ;
  21 char intent[MAXARGS][VARLEN] ;
  22 char dimensions[MAXARGS][VARLEN] ;
  23 char typedefs[MAXARGS][INLINELEN] ;
  24 int ntypedefs = 0 ;
  25 char tmp[VARLEN] ;
  26 char infname[VARLEN] ;
  27 int  nargs ;
  28 char function_type[VARLEN] ;
  29 int contained ;
  30
  31 char *ignore = "rsl" ;
  32
  33 int protex_state ;
  34
  35 set_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
  65 handle_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
  89 main( 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