osprey/libf/fort/argshck.c

Go to the documentation of this file.

/*

  Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.

  This program is free software; you can redistribute it and/or modify it
  under the terms of version 2.1 of the GNU Lesser General Public License 
  as published by the Free Software Foundation.

  This program is distributed in the hope that it would be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

  Further, this software is distributed without any warranty that it is
  free of the rightful claim of any third person regarding infringement 
  or the like.  Any license provided herein, whether implied or 
  otherwise, applies only to this software file.  Patent licenses, if
  any, provided herein do not apply to combinations of this program with 
  other software, or any other product whatsoever.  

  You should have received a copy of the GNU Lesser General Public 
  License along with this program; if not, write the Free Software 
  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
  USA.

  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
  Mountain View, CA 94043, or:

  http://www.sgi.com

  For further information regarding this notice, see:

  http://oss.sgi.com/projects/GenInfo/NoticeExplan

*/



#pragma ident "@(#) libf/fort/argshck.c 92.1  06/24/99 10:18:36"

#include <fortran.h>
#include <stdio.h>
#include <strings.h>
#include <liberrno.h>
#include <cray/nassert.h>

/*
 * Check argument shape conformance for SHARED arguments in CRAFT.
 * If an error is detected, report the called routine, the argument
 * in error and the extents of both the dummy and actual argument.
 * See message catalog for more details.
 *
 * Calls to $ARGSHCK are generated by CFT77 on MPP systems. 
 */

#define MAX_FORT_DIM  7
#define MAX_NAME_LEN  48
#define MAX_EXT_STR 80
#define MAX_ENT_LEN     32      /* Maximum entry point name length      */

typedef enum { ERR_NONE, ERR_WARN, ERR_FATAL } Error_type;

extern  int     _who_called_me();

static void ext_msg(char *label, int ext[], int rank, char extents_str[] );

static void issue_msg(int errnum, char *arg_name, char *actual_extents,
  char *dummy_extents);

void
$ARGSHCK(
void  *act_sdd, /* sdd for actual argument */
int *frml_dims, /* rank of dummy array */
int exts[],   /* array of extents in dummy array declaration */
int loc[] )   /* unpacked text containing callee & arg name */ 
{
  Error_type  error_type   = ERR_NONE;
  int   prev_cyc_ebp = 0;
  int   act_ext[ MAX_FORT_DIM ];
  char    arg_name[ MAX_NAME_LEN ];
  char    actual_extents[ MAX_EXT_STR ];
  char    dummy_extents[ MAX_EXT_STR ];
  int   act_rank;
  int   dimx;
  int   i, j;

  assert ( _issddptr(act_sdd) );  /* must be an SDD */

  for (dimx = 0; dimx < MAX_FORT_DIM; ++dimx) {
    int cyc_ebp = _sdd_read_cyc_ebp( act_sdd, dimx+1 );
    if ( cyc_ebp == 0 )
      break;
    act_ext[ dimx ] = 1 << (cyc_ebp - prev_cyc_ebp);
    prev_cyc_ebp = cyc_ebp;
  }
  act_rank = dimx;

  if ( act_rank < *frml_dims ) {
    error_type = ERR_FATAL;
  } else {
    int last_dimx = *frml_dims - 1;

    if ( act_ext[ last_dimx ] < exts[ last_dimx ] ) {
      error_type = ERR_WARN;
    }
    for (dimx = 0; dimx < last_dimx; ++dimx) {
      if ( exts[ dimx ] != act_ext[ dimx ] ) {
        error_type = ERR_FATAL;
        break;
      }
    }
      }

  if ( error_type == ERR_NONE )
    return;

/*
 *  Extract argument name from the "loc" array.
 */ 
  i = 0;
  for (j = 0; loc[ i ]; ++i ) {
    arg_name[ j++ ] = (char) loc[ i ] ;
  }
  arg_name[ j ] = '\0';

  ext_msg( "actual_arg", act_ext, act_rank,   actual_extents );
  ext_msg( "dummy_arg ", exts,    *frml_dims, dummy_extents );

  switch ( error_type ) {

  case ERR_FATAL:
    issue_msg( FEARGSHP, arg_name, actual_extents, dummy_extents );
    break;

  case ERR_WARN:
    issue_msg( FWARGSHP, arg_name, actual_extents, dummy_extents );
    break;
  }
}

static void
ext_msg(
char  *label,
int ext[],
int rank,
char  extents_str[] )
{
  int sx;
  int i;

  if ( rank > 0 ) {
    sx = sprintf( extents_str, "a %d", ext[ 0 ] );
    for (i = 1; i < rank; ++i) {
      sx += sprintf( &extents_str[ sx ], " x %d", ext[ i ]);
    }
    sprintf( &extents_str[ sx ], " element array." );
  } else {
    strcpy( extents_str, "a scalar." );
  }
}

static void
issue_msg(
int errnum,
char  *arg_name,
char  *actual_extents,
char  *dummy_extents)
{
  int nc, lineno, temp;
        char    caller[MAX_ENT_LEN];
        char    callee[MAX_ENT_LEN];

  nc  = _who_called_me(&lineno, caller, MAX_ENT_LEN, 3);
  if (nc < 0)   /* If there was an error */
    strcpy(caller, "???");
  else
    caller[nc] = '\0';

  nc  = _who_called_me(&temp, callee, MAX_ENT_LEN, 2);
  if (nc < 0)   /* If there was an error */
    strcpy(callee, "???");
  else
    callee[nc] = '\0';


  switch (errnum) {

  case FWARGSHP:
    (void) _lwarn(errnum, callee, caller, lineno, 
      arg_name, actual_extents, dummy_extents);
    break;

  case FEARGSHP:
    (void) _lerror( _LELVL_ABORT, errnum, callee, caller, lineno, 
      arg_name, actual_extents, dummy_extents);
    break;

  default:
    break;
  }
}

---