Open64: osprey/libI77/nio.c Source File

00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2.1 of the GNU Lesser General Public License 
00007   as published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU Lesser General Public 
00021   License along with this program; if not, write the Free Software 
00022   Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
00023   USA.
00024 
00025   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00026   Mountain View, CA 94043, or:
00027 
00028   http://www.sgi.com
00029 
00030   For further information regarding this notice, see:
00031 
00032   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00033 
00034 */
00035 
00036 
00037 
00038 /* $Header: /proj/osprey/CVS/open64/osprey1.0/libI77/nio.c,v 1.1.1.1 2005/10/21 19:00:00 marcel Exp $ */
00039 
00040 #include <stdio.h>
00041 #include <mutex.h>
00042 #include <math.h>
00043 #include <ctype.h>
00044 #include <string.h>
00045 #include <cmplrs/fio.h>
00046 #include "fmt.h"
00047 #include "iomode.h"
00048 #include "lio.h"
00049 #include "lread.h"
00050 #include "err.h"
00051 #include "open.h"
00052 #include "nio.h"
00053 #include "util.h"
00054 #include "bcompat.h"
00055 
00056 /*
00057  *  namelist io
00058  *
00059  *  see f77's proc.c at namelist() for description
00060  */
00061 
00062 #define BSIZ    (unsigned) 50
00063 static char     nlrs[] = "namelist read";
00064 static char    *getword(unit *, char *, unsigned int, int, int);
00065 #if 11
00066 static int c_nle (cilist64 *pcl, unit **fu);
00067 static int s_wsne64_mp (cilist64 *pnlarg, unit **fu);
00068 #else
00069 static int c_nle (cilist *pcl, unit **fu);
00070 #endif
00071 
00072 
00073 #define XINT_TYPE int
00074 #define NAMEDims  Dims
00075 #define NAMENlentry Nlentry
00076 #define NAMENamelist  Namelist
00077 
00078 #include "nio_decl.h" /* define Dims, Nlentry, Namelist */
00079 
00080 #undef XINT_TYPE
00081 #undef NAMEDims
00082 #undef NAMENlentry
00083 #undef NAMENamelist
00084 
00085 #if 11
00086 #define XINT_TYPE XINT
00087 #define NAMEDims  Dims64
00088 #define NAMENlentry Nlentry64
00089 #define NAMENamelist  Namelist64
00090 
00091 #include "nio_decl.h" /* define Dims64, Nlentry64, Namelist64 */
00092 #undef XINT_TYPE
00093 #undef NAMEDims
00094 #undef NAMENlentry
00095 #undef NAMENamelist
00096 #endif  /* -64 */
00097 
00098 
00099 /*
00100    we build 2 sets of routines for -64 -- a "compatibility" set using the
00101    32 bit interface, and a "full 64bit" set for 64bit I/O.  The 32-bit
00102    interface will generally be stubs to the 64bit routines.  For -r32/-n32
00103    we are extending the interface to "partial 64bit", there are no
00104    backwards compatibility issues here.
00105 */
00106 
00107 #define NAMEs_rsNe_work s_rsNe_work
00108 #define NAMEs_wsNe_work s_wsNe_work
00109 #if 11
00110 #define TYPEcilist  cilist64  /* we convert all cilists to cilist64 */
00111 #else
00112 #define TYPEcilist  cilist  /* pure 32 bit */
00113 #endif
00114 #define TYPENamelist  Namelist
00115 #define TYPENlentry Nlentry
00116 #define NAMEfindit  findit
00117 #define NAMEgetvar  getvar
00118 
00119 #include "nio_work.h" /* define s_rsNe_work, findit, getvar */
00120 #undef NAMEs_rsNe_work
00121 #undef NAMEs_wsNe_work
00122 #undef TYPEcilist
00123 #undef TYPENamelist
00124 #undef TYPENlentry
00125 #undef NAMEfindit
00126 #undef NAMEgetvar
00127 
00128 /* define the full 64 set */
00129 #if 11
00130 #define NAMEs_rsNe_work s_rsNe64_work
00131 #define NAMEs_wsNe_work s_wsNe64_work
00132 #define TYPEcilist  cilist64
00133 #define TYPENamelist  Namelist64
00134 #define TYPENlentry Nlentry64
00135 #define NAMEfindit  findit64
00136 #define NAMEgetvar  getvar64
00137 
00138 #include "nio_work.h" /* define s_rsNe64_work, findit64, getvar64 */
00139 #undef NAMEs_rsNe_work
00140 #undef NAMEs_wsNe_work
00141 #undef TYPEcilist
00142 #undef TYPENamelist
00143 #undef TYPENlentry
00144 #undef NAMEfindit
00145 #undef NAMEgetvar
00146 
00147 #else /* for -r32, -n32 */
00148 
00149 /* for -n32 and -r32, we dont define new routines, we simply need to
00150    equivalence s_rsNe64_work and s_wsNe64_work */
00151 
00152 #pragma weak s_rsNe64_work = s_rsNe_work
00153 #pragma weak s_wsNe64_work = s_wsNe_work
00154 
00155 #endif
00156 
00157 
00158 /*
00159  * s_rsne - start read namelist from external file
00160  *
00161  * s_rsNe and s_rsne are the same but s_wsne calls getvar_old which changes
00162  * from the old type enumeration using the match_type array in lio.h (I90)
00163  *
00164  * s_rsne
00165  *  if (file not initialized)
00166  *    intialize it
00167  *  if (file doesn't jive with namelist io)
00168  *    return error
00169  *  initialize some global variables
00170  *  if (not currently reading on file OR not capable of doing so)
00171  *    return error
00172  *  read namelist name
00173  *  if (not correct namelist name)
00174  *    error
00175  *  determine number of variables in namelist
00176  *  read variable name
00177  *  while (variable name is not "$end")
00178  *    if (variable is in namelist)
00179  *      read value(s) for it
00180  *    else
00181  *      error
00182  *  if (not correct number of variables read)
00183  *    error
00184  * end s_rsne
00185  */
00186 
00187 
00188 int
00189 s_rsne (cilist *pnlarg)
00190 {
00191    Namelist       *pnl;
00192    Nlentry        *pnlent;
00193 
00194 #if 11
00195 /* to maintain backwards compatibility and reasonable performance, we only
00196    convert the cilist structure to cilist64 */
00197  cilist64 dst;
00198  get_cilist64(&dst, pnlarg);
00199 #define WORK_ARG        &dst
00200 #else
00201 #define WORK_ARG        pnlarg
00202 #endif
00203 
00204 #ifdef I90OLD
00205         /* Fortran 90 wants to call wsne from rsne */
00206         /* also wants to use match_type in getvar */
00207  return s_rsNe_work(WORK_ARG, &f77curunit, 1, 1);
00208 
00209 #else /* ! I90OLD */
00210 
00211         /* fortran 77 does a bunch of pre-processing */
00212    pnl = (Namelist *) pnlarg->cinml;
00213    pnlent = pnl->nlvnames;
00214    do {
00215       if (pnlent->type >= 0)
00216    pnlent->type = match_type[pnlent->type];
00217       pnlent++;
00218    } while (strlen (pnlent->varname));
00219    return s_rsNe_work (WORK_ARG, &f77curunit,1,0); /* F77 wants to call s_rsne from rsne */
00220 #endif  /* I90OLD */
00221 
00222 #undef WORK_ARG
00223 }
00224 
00225 int
00226 s_rsNe (cilist *pnlarg)
00227 {
00228 #if 11
00229 /* to maintain backwards compatibility and reasonable performance, we only
00230    convert the cilist structure to cilist64 */
00231  cilist64 dst;
00232  get_cilist64(&dst, pnlarg);
00233 #define WORK_ARG  &dst
00234 #else
00235 #define WORK_ARG  pnlarg
00236 #endif
00237 #ifdef I90OLD
00238   return s_rsNe_work(WORK_ARG, &f77curunit, 0, 0);  /* but Fortran 90 wants to call wsNe
00239            from rsNe, also dont use match_type */
00240 #else
00241   return s_rsNe_work(WORK_ARG, &f77curunit, 1, 0);
00242         /* Fortran 77 wants to call wsne from
00243            rsNe */
00244 #endif
00245 #undef WORK_ARG
00246 }
00247 
00248 
00249 int
00250 s_rsNe_mp (cilist *pnlarg, unit **fu)
00251 {
00252 #if 11
00253 /* to maintain backwards compatibility and reasonable performance, we only
00254    convert the cilist structure to cilist64 */
00255  cilist64 dst;
00256  get_cilist64(&dst, pnlarg);
00257 #define WORK_ARG  &dst
00258 #else
00259 #define WORK_ARG  pnlarg
00260 #endif
00261 #ifdef I90OLD
00262   return s_rsNe_work(WORK_ARG, fu, 0, 0);  /* but Fortran 90 wants to call wsNe
00263            from rsNe, also dont use match_type */
00264 #else
00265   return s_rsNe_work(WORK_ARG, fu, 1, 0);
00266         /* Fortran 77 wants to call wsne from
00267            rsNe */
00268 #endif
00269 #undef WORK_ARG
00270 }
00271 
00272 
00273 
00274 /* miscellaneous utility functions for namelist read */
00275 
00276 /* getword - get a "word" text string from current file */
00277 
00278 static char    *getword(unit *ftnunit, char *s, unsigned int n, int skip_newline, int space_is_a_delimiter)
00279 {
00280    int             i;
00281    char           *p = s;
00282 
00283  /* If skip_newline is FALSE then we don't read past this line and
00284     return an empty string if this line contains just white spaces
00285     and a newline. PV 272510 */
00286 
00287    if (!skip_newline) {
00288       while (isspace(GETC(i))) {
00289   if (i == '\n') {
00290            *p = '\0';
00291            return s;
00292         }
00293       }
00294       UNGETC (i);
00295    }
00296 
00297 /* LHL 5/22/89
00298  * fix bug 4573
00299  * change it so that any char in the 1st column are considered as comments
00300  * till the rest of the line.
00301  */
00302 
00303    while ((GETC (i) == '\n') && (GETC (i) && (i == '*' || i == 'C' || i == 'c'))) {
00304       for (UNGETC (i); GETC (i) != '\n' && i != EOF;);
00305       if (i == '\n')
00306    UNGETC (i);
00307       if (i == EOF)
00308    break;
00309    }
00310    UNGETC (i);
00311 /* end of change */
00312    for (GETC (i);
00313    isspace (i) || (ispunct (i) && i != '?' && i != '$' && i != '&');
00314   GETC (i)) {
00315 /* LHL 5/22/89
00316  * fix bug 4573
00317  * change it so that comments are allowed anywhere within the namelist
00318  * file.
00319  */
00320       if (i == '!') {
00321    for (UNGETC (i); GETC (i) != '\n' && i != EOF;);
00322    if (i == '\n')
00323       UNGETC (i);
00324    while ((GETC (i) == '\n') && (GETC (i) && (i == '*' || i == 'C' || i == 'c'))) {
00325       for (UNGETC (i); GETC (i) != '\n' && i != EOF;);
00326       if (i == '\n')
00327          UNGETC (i);
00328       if (i == EOF)
00329          break;
00330    }
00331    UNGETC (i);
00332       }
00333 /* end of change */
00334    }
00335    if (space_is_a_delimiter) {
00336      while (n--) {
00337         if (i != EOF && i != '=' && !isspace (i) )
00338            *p++ = (isupper (i) ? i + 'a' - 'A' : i);
00339         else
00340            break;
00341         GETC (i);
00342      } /* while loop */
00343    } else {
00344      while (n--) {
00345         if (i != EOF && i != '=' && (!isspace (i) || i == ' ' || i == '\t'))
00346            *p++ = (isupper (i) ? i + 'a' - 'A' : i);
00347         else
00348            break;
00349         GETC (i);
00350      } /* while loop */
00351    }    /* if */
00352 
00353 /* LHL 5/22/89
00354  * fix bug 4573
00355  * make sure that '\n' gets back to the input stream.
00356  */
00357    if (i == '\n')
00358       UNGETC (i);
00359 /* end of change */
00360    if (feof (ftnunit->ufd) && p == s)
00361       return NULL;
00362    *p = '\0';
00363    return s;
00364 }
00365 
00366 
00367 /*
00368  * s_wsne - start write namelist 
00369  *
00370  * s_wsne
00371  *  if (file not initialized)
00372  *    initialize it
00373  *  if (file doesn't jive with namelist io)
00374  *    return error
00375  *  initialize some global variables
00376  *  if (not currently writing on file OR not capable of doing so)
00377  *    return error
00378  *  set up namelist and entry pointers
00379  *  output namelist name in proper format
00380  *  do
00381  *    output variable name
00382  *    output value based on type
00383  *    point to next entry
00384  *  while (there are more to do AND sneakily output a comma separator)
00385  *  output end line
00386  * end s_wsne
00387  */
00388 
00389 /* compatibility bug fix */
00390 int
00391 s_wsne (cilist *pnlarg)
00392 {
00393 #if 11
00394 /* to maintain backwards compatibility and reasonable performance, we only
00395    convert the cilist structure to cilist64 */
00396  cilist64 dst;
00397  get_cilist64(&dst, pnlarg);
00398 #ifdef I90OLD
00399  return s_wsNe_work(&dst, &f77curunit, 1);
00400 #else
00401  return s_wsNe_work(&dst, &f77curunit, 0);
00402 #endif
00403 
00404 #else
00405 #ifdef I90OLD
00406  return s_wsNe_work(pnlarg, &f77curunit, 1);
00407 #else
00408  return s_wsNe_work(pnlarg, &f77curunit, 0);
00409 #endif
00410 
00411 #endif
00412 }
00413 
00414 int
00415 s_wsne_mp (cilist *pnlarg, unit **fu)
00416 {
00417    Namelist       *pnl;
00418    Nlentry        *pnlent;
00419 #if 11
00420 /* to maintain backwards compatibility and reasonable performance, we only
00421    convert the cilist structure to cilist64 */
00422  cilist64 dst;
00423  get_cilist64(&dst, pnlarg);
00424 #define WORK_ARG        &dst
00425 #else
00426 #define WORK_ARG        pnlarg
00427 #endif
00428 
00429 #ifdef I90OLD
00430   /* Fortran 90: set use_match_type to use match_type, but doesn't
00431     set it in the list - dont know if it makes any difference
00432     but thats the way the code goes */
00433  return s_wsNe_work(WORK_ARG, fu, 1);
00434 
00435 #else /* ! I90 */
00436 
00437   /* Fortran 77: does match_type up-front, sets it in the list */
00438    pnl = (Namelist *) pnlarg->cinml;
00439    pnlent = pnl->nlvnames;
00440    do {
00441       if (pnlent->type >= 0)
00442    pnlent->type = match_type[pnlent->type];
00443       pnlent++;
00444    } while (strlen (pnlent->varname));
00445    return s_wsNe_work (WORK_ARG, fu, 0);
00446 #endif
00447 
00448 #undef WORK_ARG
00449 }
00450 
00451 #if 11
00452 static int
00453 s_wsne64_mp (cilist64 *pnlarg, unit **fu)
00454 {
00455    Namelist       *pnl;
00456    Nlentry        *pnlent;
00457 
00458 #ifdef I90OLD
00459   /* Fortran 90: set use_match_type to use match_type, but doesn't
00460     set it in the list - dont know if it makes any difference
00461     but thats the way the code goes */
00462  return s_wsNe_work(pnlarg, fu, 1);
00463 
00464 #else /* ! I90 */
00465 
00466   /* Fortran 77: does match_type up-front, sets it in the list */
00467    pnl = (Namelist *) pnlarg->cinml;
00468    pnlent = pnl->nlvnames;
00469    do {
00470       if (pnlent->type >= 0)
00471    pnlent->type = match_type[pnlent->type];
00472       pnlent++;
00473    } while (strlen (pnlent->varname));
00474    return s_wsNe_work (pnlarg, fu, 0);
00475 #endif
00476 
00477 }
00478 #endif
00479 
00480 
00481 int
00482 s_wsNe (cilist *pnlarg)
00483 {
00484 #if 11
00485 /* to maintain backwards compatibility and reasonable performance, we only
00486    convert the cilist structure to cilist64 */
00487  cilist64 dst;
00488  get_cilist64(&dst, pnlarg);
00489 #define WORK_ARG  &dst
00490 #else
00491 #define WORK_ARG  pnlarg
00492 #endif
00493     return( s_wsNe_work( WORK_ARG, &f77curunit, 0 ) );
00494 #undef WORK_ARG
00495 }
00496 
00497 
00498 int
00499 s_wsNe_mp (cilist *pnlarg, unit **fu)
00500 {
00501 #if 11
00502 /* to maintain backwards compatibility and reasonable performance, we only
00503    convert the cilist structure to cilist64 */
00504  cilist64 dst;
00505  get_cilist64(&dst, pnlarg);
00506 #define WORK_ARG  &dst
00507 #else
00508 #define WORK_ARG  pnlarg
00509 #endif
00510    return s_wsNe_work(WORK_ARG, fu, 0);
00511   /* dont set use_match_type */
00512 #undef WORK_ARG
00513 }
00514 
00515 
00516 /*
00517  * c_nle - check namelist 
00518  *
00519  * c_nle
00520  *  set up global variables
00521  *  if (bogus unit)
00522  *    f77fatal error
00523  *  if (unit is unitialized AND can't be)
00524  *    f77fatal error
00525  *  if (can't do unformatted io on unit)
00526  *    f77fatal error
00527  * end c_nle
00528  */
00529 
00530 static
00531 int
00532 #if 11
00533 c_nle (cilist64 *pcl, unit **fu)
00534 #else
00535 c_nle (cilist *pcl, unit **fu)
00536 #endif
00537 {
00538    unit   *ftnunit;
00539 
00540    ftnunit = *fu = map_luno (pcl->ciunit);
00541    while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
00542        ;
00543    if (ftnunit->uconn <= 0 && fk_open (SEQ, FMT, pcl->ciunit)) {
00544       ftnunit->uconn = 0;
00545       errret(pcl->cierr, 102, "namelist io");
00546    }
00547    ftnunit->f77fmtbuf = "namelist io";
00548    ftnunit->f77scale = 0;
00549    ftnunit->f77recpos = 0;
00550    ftnunit->ufd = ftnunit->ufd;
00551 
00552    if (!ftnunit->ufmt)
00553       errret(pcl->cierr, 103, "namelist io");
00554    return (0);
00555 }
00556 
00557 #pragma weak __kai_s_rsne = s_rsNe
00558 #pragma weak __kai_s_wsne = s_wsNe
00559 #pragma weak __kai_s_rsne_mp = s_rsNe_mp
00560 #pragma weak __kai_s_wsne_mp = s_wsNe_mp
00561 
00562 /* now declare all the 64 bit versions */
00563 #if 11
00564 
00565 int
00566 s_rsNe64(cilist64 *pnlarg)
00567   {
00568   return s_rsNe64_work(pnlarg, &f77curunit, 1, 0);
00569   }
00570 
00571 int
00572 s_rsNe64_mp(cilist64 *pnlarg, unit **fu)
00573   {
00574   return s_rsNe64_work(pnlarg, fu, 1, 0);
00575   }
00576 
00577 int
00578 s_wsNe64(cilist64 *pnlarg)
00579   {
00580   return( s_wsNe64_work(pnlarg, &f77curunit, 0 ));
00581   }
00582 
00583 int
00584 s_wsNe64_mp(cilist64 *pnlarg, unit **fu)
00585   {
00586   return( s_wsNe64_work(pnlarg, fu, 0));
00587   }
00588 
00589 #pragma weak __kai_s_rsne64 = s_rsNe64
00590 #pragma weak __kai_s_wsne64 = s_wsNe64
00591 #pragma weak __kai_s_rsne64_mp = s_rsNe64_mp
00592 #pragma weak __kai_s_wsne64_mp = s_wsNe64_mp
00593 
00594 #endif