Open64: osprey/libf/fort/bounds

00001 /*
00002  * Copyright 2004 PathScale, Inc.  All Rights Reserved.
00003  */
00004 
00005 /*
00006 
00007   Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.
00008 
00009   This program is free software; you can redistribute it and/or modify it
00010   under the terms of version 2.1 of the GNU Lesser General Public License 
00011   as published by the Free Software Foundation.
00012 
00013   This program is distributed in the hope that it would be useful, but
00014   WITHOUT ANY WARRANTY; without even the implied warranty of
00015   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00016 
00017   Further, this software is distributed without any warranty that it is
00018   free of the rightful claim of any third person regarding infringement 
00019   or the like.  Any license provided herein, whether implied or 
00020   otherwise, applies only to this software file.  Patent licenses, if
00021   any, provided herein do not apply to combinations of this program with 
00022   other software, or any other product whatsoever.  
00023 
00024   You should have received a copy of the GNU Lesser General Public 
00025   License along with this program; if not, write the Free Software 
00026   Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
00027   USA.
00028 
00029   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00030   Mountain View, CA 94043, or:
00031 
00032   http://www.sgi.com
00033 
00034   For further information regarding this notice, see:
00035 
00036   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00037 
00038 */
00039 
00040 
00041 
00042 #pragma ident "@(#) libf/fort/bounds_chk.c  92.1  06/24/99 10:18:36"
00043 #include <fortran.h>
00044 #include <liberrno.h>
00045 #include <stddef.h>
00046 #if defined(__mips) || defined(_LITTLE_ENDIAN)
00047 #include <stdlib.h>
00048 #endif
00049 #include "fio.h"
00050 
00051 /*
00052  *  Error handler for an of out-of-bounds subscript warning.
00053  *  This entry is called by the cf90 compiler only.
00054  *
00055  *  Input Arguments:
00056  *    file     - File name in which error occurred.
00057  *    line     - Line number in file.
00058  *    variable - Name of array which had an out-of-bounds subscript.
00059  *    dim      - Dimension number of the array.
00060  *    lowerbnd - Lower bound of dimension dim
00061  *    upperbnd - Upper bound of dimension dim
00062  *    sub      - Out-of-bounds subscript value.
00063  *    count    - Static count/flag to indicate if this message was
00064  *               already given for this statement.
00065  */
00066 
00067 void
00068 _BOUNDS_ERROR(
00069   char  *file,    /* Fortran routine containing error */
00070   int *line,    /* Line number in Fortran routine */
00071   char  *variable,  /* arrayname with out-of-bounds subscript */
00072   int *dim,   /* Dimension number of the array */
00073   int *lowerbnd,  /* Lower bound of dimension dim */
00074   int *upperbnd,  /* Upper bound of dimension dim */
00075   int sub[1],   /* Out-of-bounds subscript value */
00076   int *count)   /* Count/flag for number of messages */
00077 {
00078   int *retcnt;  /* ptr to static arg count word */
00079   int intcnt = 0; /* local count if no count passed */
00080 #ifdef  _UNICOS
00081   /* Use local variable if count argument not passed. */
00082   if (_numargs() < 8)
00083     retcnt  = &intcnt;
00084   else
00085 #endif
00086     retcnt  = count;
00087   if ((*retcnt)++ == 0) {
00088     (void) _fwarn(FWARGSBV, sub[0], *dim, variable, *line,
00089        file, *lowerbnd, *upperbnd);
00090   }
00091   return;
00092 }
00093 
00094 /*
00095  *  Error handler for a range of out-of-bounds subscripts.
00096  *  This entry is called by the cf90 compiler only.
00097  *
00098  *  Input:
00099  *    file     - File name in which error occurred.
00100  *    line     - Line number in file.
00101  *    variable - Name of array which had an out-of-bounds subscript.
00102  *    dim      - Dimension number of the array.
00103  *    lowerbnd - Lower bound of dimension dim
00104  *    upperbnd - Upper bound of dimension dim
00105  *    start    - Starting subscript which is out of bounds.
00106  *    end      - Ending subscript which is out of bounds.
00107  *    incr     - Increment between subscripts.
00108  *    count    - Static count/flag to indicate if this message was
00109  *               already given for this statement.
00110  */
00111 
00112 void
00113 _RBOUNDS_ERROR(
00114   char  *file,    /* Fortran routine containing error */
00115   int *line,    /* Line number in Fortran routine */
00116   char  *variable,  /* arrayname with out-of-bounds subscript */
00117   int *dim,   /* Dimension number with size mismatch */
00118   int *lowerbnd,  /* Lower bound of dimension dim */
00119   int *upperbnd,  /* Upper bound of dimension dim */
00120   int *start,   /* Out-of-bounds starting subscript */
00121   int *end,   /* Out-of-bounds ending subscript */
00122   int *incr,    /* Increment between subscript */
00123   int *count)   /* Count/flag for number of messages */
00124 {
00125   int *retcnt;  /* ptr to static arg count word */
00126   int intcnt = 0; /* local count if no count passed */
00127 #ifdef  _UNICOS
00128   /* Use local variable if count argument not passed. */
00129   if (_numargs() < 10)
00130     retcnt  = &intcnt;
00131   else
00132 #endif
00133     retcnt  = count;
00134   if ((*retcnt)++ == 0) {
00135     (void) _fwarn(FWARGSBR, *start, *end, *incr, *dim,
00136       variable, *line, file, *lowerbnd, *upperbnd);
00137   }
00138   return;
00139 }
00140 
00141 /*
00142  *  Error handler for a vector of out-of-bounds subscripts.
00143  *  This entry is called by the cf90 compiler only.
00144  *
00145  *  Input:
00146  *    file     - File name in which error occurred.
00147  *    line     - Line number in file.
00148  *    variable - Name of array which had an out-of-bounds subscript.
00149  *    dim      - Dimension number of the array.
00150  *    lowerbnd - Lower bound of dimension dim
00151  *    upperbnd - Upper bound of dimension dim
00152  *    sub      - Array of subscripts.
00153  *    vm       - Bit mask of which subscripts are in error.
00154  *    vl       - Number of subscripts passed.
00155  *    count    - Static count/flag to indicate if this message was
00156  *               already given for this statement.
00157  */
00158 
00159 void
00160 _VBOUNDS_ERROR(
00161   char  *file,    /* Fortran routine with error */
00162   int *line,    /* Line number in Fortran routine */
00163   char  *variable,  /* Arrayname with out-of-bounds subscript */
00164   int *dim,   /* Dimension number of the array */
00165   int *lowerbnd,  /* Lower bound of dimension dim */
00166   int *upperbnd,  /* Upper bound of dimension dim */
00167   int sub[128], /* Array of subscripts */
00168   long  vm[2],    /* Bit mask of the subscripts in error */
00169   int *vl,    /* Number of subscripts passed */
00170   int *count)   /* Count/flag for number of messages */
00171 {
00172   int   i, len;
00173   long  mask;
00174   int   stride;
00175   int   first_error_sub;
00176   int   last_error_sub;
00177   int   constant_stride = 1;
00178   int   error_count     = 0;
00179   int *retcnt;  /* ptr to static arg count word */
00180   int intcnt = 0; /* local count if no count passed */
00181 #ifdef  _UNICOS
00182   /* Use local variable if count argument not passed. */
00183   if (_numargs() < 10)
00184     retcnt  = &intcnt;
00185   else
00186 #endif
00187     retcnt  = count;
00188   if ((*retcnt)++ != 0)
00189     return;
00190   len = *vl;
00191   for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
00192     if ( i == 64 ) {
00193       mask  = vm[1];
00194     }
00195     if ( mask < 0 ) {
00196       error_count++;
00197       if ( error_count == 1 ) {
00198         first_error_sub = sub[i];
00199       }
00200       else if ( error_count == 2 ) {
00201         stride  = sub[i] - last_error_sub;
00202       }
00203       else {
00204         if ( stride != sub[i] - last_error_sub ) {
00205           constant_stride = 0;
00206           break;
00207         }
00208       }
00209       last_error_sub  = sub[i];
00210     }
00211   }
00212   if ( error_count == 1 ) {
00213     (void) _fwarn(FWARGSBV, first_error_sub, *dim, variable,
00214         *line, file, *lowerbnd, *upperbnd);
00215     return;
00216   }
00217   else if ( constant_stride ) {
00218     if ( stride == 0 ) {
00219       (void) _fwarn(FWARGSBV, first_error_sub, *dim,
00220           variable, *line, file, *lowerbnd,
00221           *upperbnd);
00222     }
00223     else {
00224       (void) _fwarn(FWARGSBR, first_error_sub,
00225           last_error_sub, stride, *dim,
00226           variable, *line, file, *lowerbnd,
00227           *upperbnd);
00228     }
00229     return;
00230   }
00231   for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
00232     if ( i == 64 ) {
00233       mask = vm[1];
00234     }
00235     if ( mask < 0 ) {
00236       (void) _fwarn(FWARGSBV, sub[i], *dim, variable,
00237           *line, file, *lowerbnd, *upperbnd);
00238     }
00239   }
00240 }
00241 
00242 
00243 /*
00244  *  Error handler for a vector of out-of-bounds ranges.
00245  *  This entry is called by the cf90 compiler only.
00246  *
00247  *  Input:
00248  *    file     - File name in which error occurred.
00249  *    line     - Line number in file.
00250  *    variable - Name of array which had an out-of-bounds subscript.
00251  *    dim      - Dimension number of the array.
00252  *    lowerbnd - Lower bound of dimension dim
00253  *    upperbnd - Upper bound of dimension dim
00254  *    start    - Array of starting subscripts
00255  *    end      - Array of ending subscripts
00256  *    incr     - Array of increments
00257  *    vm       - Bit mask of which subscripts are in error.
00258  *    vl       - Number of subscripts passed.
00259  *    count    - Static count/flag to indicate if this message was
00260  *               already given for this statement.
00261  */
00262 
00263 void
00264 _VRBOUNDS_ERROR(
00265   char    *file,    /* Fortran routine with error */
00266   int     *line,    /* Line number in Fortran routine */
00267   char    *variable,  /* Arrayname with out-of-bounds subscript */
00268   int     *dim,   /* Dimension number of the array */
00269   int     *lowerbnd,  /* Lower bound of dimension dim */
00270   int     *upperbnd,  /* Upper bound of dimension dim */
00271   int     start[128], /* Out-of-bounds starting subscript */
00272   int     end[128], /* Out-of-bounds ending subscript */
00273   int     incr[128],  /* Increment between subscript */
00274   long    vm[2],    /* Bit mask of the subscripts in error */
00275   int     *vl,    /* Number of subscripts passed */
00276   int *count)   /* Count/flag for number of messages */
00277 {
00278   int   i, len;
00279   long  mask;
00280   int   first_error_start;
00281   int   first_error_end;
00282   int   first_error_incr;
00283   int   all_same    = 1;
00284   int   first_error = 1;
00285   int *retcnt;  /* ptr to static arg count word */
00286   int intcnt = 0; /* local count if no count passed */
00287 
00288 #ifdef  _UNICOS
00289   /* Use local variable if count argument not passed. */
00290   if (_numargs() < 12)
00291     retcnt  = &intcnt;
00292   else
00293 #endif
00294     retcnt  = count;
00295   if ((*retcnt)++ != 0)
00296     return;
00297   len = *vl;
00298   for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
00299     if ( i == 64 ) {
00300       mask  = vm[1];
00301     }
00302     if ( mask < 0 ) {
00303       if ( first_error ) {
00304         first_error   = 0;
00305         first_error_start = start[i];
00306         first_error_end   = end[i];
00307         first_error_incr  = incr[i];
00308       }
00309       else if ( first_error_start != start[i] ||
00310                 first_error_end   !=   end[i] ||
00311                 first_error_incr  !=  incr[i] ) {
00312         all_same  = 0;
00313         break;
00314       }
00315     }
00316   }
00317   if ( all_same ) {
00318     (void) _fwarn(FWARGSBR, first_error_start,
00319         first_error_end, first_error_incr, *dim,
00320         variable, *line, file, *lowerbnd,
00321         *upperbnd);
00322     return;
00323   }
00324   for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
00325     if ( i == 64 ) {
00326       mask  = vm[1];
00327     }
00328     if ( mask < 0 ) {
00329       (void) _fwarn(FWARGSBR, start[i], end[i], incr[i],
00330           *dim, variable, *line, file,
00331           *lowerbnd, *upperbnd);
00332     }
00333   }
00334 }
00335 
00336 /*
00337  *  Error handler for an of out of bounds substring.
00338  *
00339  *  Input:
00340  *    file     - File name in which error occurred.
00341  *    line     - Line number in file.
00342  *    variable - Name of array which had an out of bounds substring.
00343  *    size     - Substring size.
00344  *    start    - Out of bounds substring start.
00345  *    length   - Out of bounds substring length.
00346  *    count    - Static count/flag to indicate if this message was
00347  *               already given for this statement.
00348  */
00349 void
00350 _SBOUNDS_ERROR(
00351     char *file,
00352     int *line,
00353     char *variable,
00354     int *size,
00355                 int *subst,
00356                 int *subln,
00357                 int *count )
00358 {
00359   int *retcnt;  /* ptr to static arg count word */
00360   int intcnt = 0; /* local count if no count passed */
00361   int endst;
00362 #ifdef  _UNICOS
00363   /* Use local variable if count argument not passed. */
00364   if (_numargs() < 7)
00365     retcnt  = &intcnt;
00366   else
00367 #endif
00368     retcnt  = count;
00369 
00370   /* if substring length is zero or negative, not incorrect */
00371   if ( *subln > 0) {
00372     if ((*retcnt)++ == 0) {
00373 
00374       /* calculate substring end.
00375        * subln is calculated by (ln = s2 - s1 + 1)
00376        * endst is calculated by (s2 = ln + s1 - 1)
00377        */
00378       endst = *subln + *subst - 1;
00379       (void) _fwarn (FWARGSTR, *subst, endst, variable,
00380          *line, file, *size);
00381     }
00382   }
00383   return;
00384 }
00385 
00386 #if defined(__mips) || defined(_LITTLE_ENDIAN)
00387 void
00388 __f90_bounds_check(char *procedure_name, _f_int4 line_number, char *array_name, _f_int4 axis_number)
00389 {
00390   char  *unknown_nm = "name_unknown";
00391   char  *abort_now = NULL;
00392   char  *rtn_nm = "__f90_bounds_check";
00393 
00394   /* note mips f90 compiler appends extra characters at
00395    * the end of the procedure name.
00396    */
00397  
00398   /* MIPSpro 7.2 and 7.2.1 documentation assumed that the
00399    * routine would abort if this environment variable is
00400    * is set.  Otherwise, the message is just a warning.
00401    */
00402   abort_now = getenv("F90_BOUNDS_CHECK_ABORT");
00403   if (abort_now) {
00404     if (*abort_now == 'y' || *abort_now == 'Y') {
00405       if (array_name) {
00406         (void) _lerror(_LELVL_MSG, FWARGSVB, 
00407            axis_number, array_name, line_number,
00408            procedure_name, rtn_nm);
00409       } else {
00410         (void) _lerror(_LELVL_MSG, FWARGSVB,
00411            axis_number, unknown_nm, line_number,
00412            procedure_name, rtn_nm);
00413       }
00414 
00415       /* cleanup the fortran units before abort */
00416       _fcleanup();
00417       abort();
00418     }
00419   }
00420   if (array_name)
00421     (void) _fwarn(FWARGSVB,axis_number, array_name,
00422        line_number, procedure_name, rtn_nm);
00423   else
00424     (void) _fwarn(FWARGSVB,axis_number, unknown_nm,
00425        line_number, procedure_name, rtn_nm);
00426   return;
00427 }
00428 #endif    /* end __mips */
osprey/libf/fort/bounds_chk.c
