|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
|
Open64 (mfef90, whirl2f, and IR tools)
TAG: version-openad; SVN changeset: 916
|
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 #pragma ident "@(#) libf/fio/rnl90.c 92.9 10/12/99 13:16:22" 00039 00040 #include <stdio.h> 00041 #include <errno.h> 00042 #include <liberrno.h> 00043 #include <fortran.h> 00044 #include <stdlib.h> 00045 #include <cray/fmtconv.h> 00046 #include <cray/nassert.h> 00047 #if !defined(_ABSOFT) 00048 #include <sys/unistd.h> 00049 #endif 00050 #include "fio.h" 00051 #include "namelist.h" 00052 #include "rnl90def.h" 00053 00054 /* EXTERNAL entry points */ 00055 extern int _s_scan_extensions(void *ptr, ftype_t type, 00056 unsigned long elsize, long *field_begin, 00057 unsigned long rec_chars, int *fwptr, long cmode); 00058 extern int _nicverr(const int _Nicverror); 00059 00060 /* use SUBGTC when the character retrieval cannot hit an end of file until 00061 * the retrieval is complete. This occurs when retrieving the characters of 00062 * a name. This macro is used in functions outside the main namelist FRN 00063 * routine. 00064 */ 00065 00066 #define SUBGTC(x) { \ 00067 while (cup->ulinecnt == 0) { \ 00068 if (errn = _nlrd_fillrec(css, cup)) { \ 00069 return(errn); \ 00070 } \ 00071 } \ 00072 x = (char) *cup->ulineptr++; \ 00073 cup->ulinecnt--; \ 00074 } 00075 00076 #define SUBGTCNOEOR(x) { \ 00077 if (!cup->ulinecnt) { \ 00078 x = ' '; \ 00079 } else { \ 00080 x = (char) *cup->ulineptr++; \ 00081 cup->ulinecnt--; \ 00082 } \ 00083 } 00084 00085 /* Fortran 95 provides an exclamation point as an input record 00086 * comment character. Prepare for its addition in 3.0+. If 00087 * comment begins an input record, ignore the rest of the 00088 * input record and get the next input record. 00089 */ 00090 00091 #define CMTE_SUBGTC(x) { \ 00092 while (cup->ulinecnt == 0) { \ 00093 if (errn = _nlrd_fillrec(css, cup)) { \ 00094 return(errn); \ 00095 } \ 00096 } \ 00097 x = (char) *cup->ulineptr++; \ 00098 if (x == '!') { \ 00099 x = ' '; \ 00100 cup->ulinecnt = 1; \ 00101 } \ 00102 cup->ulinecnt--; \ 00103 } 00104 00105 #define CMTE_SUBGTCNOEOR(x) { \ 00106 if (!cup->ulinecnt) { \ 00107 x = ' '; \ 00108 } else { \ 00109 x = (char) *cup->ulineptr++; \ 00110 cup->ulinecnt--; \ 00111 } \ 00112 if (x == '!') { \ 00113 x = ' '; \ 00114 cup->ulinecnt = 0; \ 00115 } \ 00116 } 00117 00118 00119 00120 /* use MAINGT when the character retrieval can hit an end of file before 00121 * retrieval is complete. This occurs when retrieving '=', delimiters, 00122 * , etc. This macro is used in functions within the main namelist FRN 00123 * routine. CMTE_MAINGT is the same except comments are allowed for F95. 00124 */ 00125 00126 #define MAINGT(x) { \ 00127 while (cup->ulinecnt == 0) { \ 00128 if (errn = _nlrd_fillrec(css, cup)) { \ 00129 if (errn < 0) { \ 00130 ENDD(endf, css, FERDPEOF); \ 00131 } \ 00132 else { \ 00133 ERROR0(errf, css, errn); \ 00134 } \ 00135 } \ 00136 } \ 00137 x = (char) *cup->ulineptr++; \ 00138 cup->ulinecnt--; \ 00139 } 00140 00141 #define CMTE_MAINGT(x) { \ 00142 while (cup->ulinecnt == 0) { \ 00143 if (errn = _nlrd_fillrec(css, cup)) { \ 00144 if (errn < 0) { \ 00145 ENDD(endf, css, FERDPEOF); \ 00146 } \ 00147 else { \ 00148 ERROR0(errf, css, errn); \ 00149 } \ 00150 } \ 00151 } \ 00152 x = (char) *cup->ulineptr++; \ 00153 /* CHECK for comment */ \ 00154 if (x == '!') { \ 00155 x = ' '; \ 00156 cup->ulinecnt = 1; \ 00157 } \ 00158 cup->ulinecnt--; \ 00159 } 00160 00161 #define GETSECTION(x) { \ 00162 field_begin = cup->ulineptr; \ 00163 field_end = cup->ulineptr; \ 00164 for (j = 0; j < cup->ulinecnt; j++) { \ 00165 x = (char) *field_end; \ 00166 if (x == ')' || x == ',' || x == ':') \ 00167 break; \ 00168 field_end++; \ 00169 } \ 00170 field_width = j; \ 00171 } 00172 00173 /* 00174 * This table is used to drive the f90 input conversion based on the 00175 * type of the data. 00176 */ 00177 ic_func *ncf_tab90[] = { 00178 NULL, /* DVTYPE_UNUSED */ 00179 NULL, /* DVTYPE_TYPELESS */ 00180 _iu2s, /* DVTYPE_INTEGER */ 00181 _defgu2sd, /* DVTYPE_REAL */ 00182 _defgu2sd, /* DVTYPE_COMPLEX */ 00183 NULL, /* DVTYPE_LOGICAL */ 00184 NULL, /* DVTYPE_ASCII */ 00185 }; 00186 00187 static int _nlrd_fillrec(FIOSPTR css, unit *cup); 00188 00189 static int _getname(FIOSPTR css, unit *cup, char *buf, char *lastc); 00190 00191 static void _cnvrt_toupper(char *bufr); 00192 00193 static nmlist_goli_t *_findname(char *key, nmlist_goli_t *nlvar, 00194 unsigned countitm); 00195 00196 static int _getnlval(FIOSPTR css, nmlist_goli_t *nlvar, char *lastc, 00197 unit *cup); 00198 00199 static int _indx_nl(FIOSPTR css, unit *cup, struct DvDimen *dvdn, 00200 int *ndim, long strbegend[3], int *encnt, int *icnt, int arryflag); 00201 00202 static int _nlrdent(FIOSPTR css,unit *cup,nmlist_goli_t *nalist, 00203 unsigned count, char *lastc, int byt); 00204 00205 static int _nlread(FIOSPTR css, ftype_t type, unit *cup, void *ptr, 00206 long elsize, int cnt, int inc, char *lastc); 00207 00208 static int _nexdata(FIOSPTR css, ftype_t type, void *ptr, int cnt, int inc, 00209 char lastc, unit *cup, long *lval, int *lcount, long elsize, int *nullvlu); 00210 00211 static int _g_charstr(FIOSPTR css, unit *cup, void *p, int cnt, char c, 00212 int lcount, long elsize, int *nullvlu); 00213 00214 static int _g_complx(FIOSPTR css, unit *cup, ftype_t type, long *lval, 00215 long elsize); 00216 00217 static int _g_number(ftype_t type, unit *cup,long *lval, long elsize); 00218 00219 static int _gocthex(FIOSPTR css, unit *cup, ftype_t type, long *lval, int base, 00220 long elsize, int *nullvlu); 00221 00222 static int _get_holl(FIOSPTR css, unit *cup, char holltype, int count, 00223 ftype_t type, long *lval, long elsize); 00224 00225 static int _get_quoholl(FIOSPTR css, unit *cup, char cdelim, ftype_t type, 00226 long *lval, long elsize); 00227 00228 static int _nl_stride_dv(FIOSPTR css, unit *cup, DopeVectorType *dv, 00229 struct DvDimen *sectn, char *lastc, long strbegend[3]); 00230 00231 static int _nl_strd_derv( FIOSPTR css, unit *cup, DopeVectorType *dv, 00232 struct DvDimen *sectn, char *lastch, nmlist_goli_t *vdr, 00233 unsigned int cnt, long bte); 00234 00235 /* 00236 * _FRN - called by compiled Fortran programs to process a namelist 00237 * read statement. 00238 * Synopsis 00239 * int _FRN( ControlListType *cilist, 00240 * nmlist_group *namlist, 00241 * void *stck); 00242 * Where 00243 * cilist - pointer to the control information list 00244 * information. This describes the specifiers 00245 * for the current I/O statement. 00246 * namlist - pointer to the namelist table. 00247 * stck - pointer to stack space which is passed 00248 * to each call to _FRU for a particular 00249 * statement. This is used by the library. 00250 * Return value 00251 * IO_OKAY, IO_END, or IO_ERR 00252 */ 00253 00254 int 00255 _FRN(ControlListType *cilist, nmlist_group *namlist, void *stck) 00256 { 00257 char buf[MAXNAML + 5], c; 00258 int errf; /* Error processing flag */ 00259 int endf; /* EOF processing flag */ 00260 int errn; /* Error number */ 00261 register unum_t unum; /* Actual unit number */ 00262 unit *cup; /* Pointer to unit table entry */ 00263 unsigned long rlen; /* group name length */ 00264 unsigned long rcount; /* count of namelist items */ 00265 char *rptr; /* pointer to group name */ 00266 char *varptr; /* ptr to group_obj_list item */ 00267 unsigned long varlen; /* len of group_obj_list name */ 00268 nmlist_goli_t *nlvar; /* ptr to next variable entry */ 00269 nmlist_goli_t *fdvar; /* ptr to next variable entry */ 00270 ftype_t type; 00271 char endnmlchar; /* namelist group name char */ 00272 FIOSPTR css; 00273 00274 /* Assertions */ 00275 /* Validate that the size of *stck is large enough */ 00276 assert ( cilist->stksize >= sizeof(struct fiostate)/sizeof(long) ); 00277 00278 /* The compiler flags namelist with fmt flag */ 00279 assert( (cilist->fmt == CI_NAMELIST)); 00280 00281 /* The compiler disallows namelist with internal files */ 00282 assert( !(cilist->internal && cilist->fmt == CI_NAMELIST)); 00283 00284 /* The compiler disallows namelist with direct files */ 00285 assert( !(cilist->dflag && cilist->fmt == CI_NAMELIST)); 00286 00287 css = stck; 00288 errn = 0; 00289 type = DVTYPE_UNUSED; 00290 varptr = NULL; 00291 00292 /* ************************************************************************** 00293 * Statement Initialization Section 00294 ************************************************************************* */ 00295 00296 /* Establish error processing options */ 00297 errf = (cilist->errflag || cilist->iostatflg); 00298 endf = (cilist->endflag || cilist->iostatflg); 00299 00300 if (cilist->uflag == CI_UNITASTERK) 00301 unum = STDIN_U; 00302 else 00303 unum = *cilist->unit.wa; 00304 00305 STMT_BEGIN(unum, 0, T_RNL, NULL, css, cup); 00306 00307 if (cup == NULL) { /* If not connected */ 00308 cup = _imp_open(css, SEQ, FMT, unum, errf, &errn); 00309 /* 00310 * If the open failed, cup is NULL and errn contains 00311 * the error number. 00312 */ 00313 if (cup == NULL) 00314 goto finalization; 00315 } 00316 /* All paths which lead here have set cup to a non-null value */ 00317 assert (cup != NULL); 00318 00319 /* Copy the user's error processing options into the unit table */ 00320 cup->uflag = (cilist->errflag ? _UERRF : 0) | 00321 (cilist->endflag ? _UENDF : 0) | 00322 (cilist->iostat_spec != NULL ? _UIOSTF : 0); 00323 css->u.fmt.nonadv = 0; 00324 00325 /* If trying to read a file without read permission */ 00326 if ((cup->uaction & OS_READ) == 0) { 00327 errn = FENOREAD; 00328 ERROR0(errf, css, errn); 00329 } 00330 /* If attempting formatted I/O on an unformatted file */ 00331 if (!cup->ufmt) { 00332 errn = FEFMTTIV; 00333 ERROR0(errf, css, errn); 00334 } 00335 /* If sequential and writing, disallow read after write */ 00336 if (cup->useq && cup->uwrt != 0) { 00337 errn = FERDAFWR; 00338 ERROR0(errf, css, errn); 00339 } 00340 00341 /* Preset fields in unit table */ 00342 00343 cup->uwrt = 0; 00344 00345 /* Initialize fields in the Fortran statement state structure */ 00346 00347 css->u.fmt.icp = NULL; 00348 css->u.fmt.blank0 = cup->ublnk; 00349 css->u.fmt.lcomma = 0; 00350 css->u.fmt.slash = 0; 00351 00352 if (cup->useq == 0) { /* If seq. attempted on direct file */ 00353 errn = FESEQTIV; /* Sequential not allowed */ 00354 ERROR0(errf, css, errn); 00355 } 00356 /* external sequential formatted I/O */ 00357 if (cup->uend && !cup->umultfil) { /* If after endfile */ 00358 errn = FERDENDR; /* Read after endfile */ 00359 ERROR0(endf, css, errn); 00360 } 00361 00362 css->u.fmt.endrec = _sr_endrec; 00363 00364 if (cup->pnonadv == 0) /* if previous ADVANCE='YES' */ 00365 errn = (*css->u.fmt.endrec)(css, cup, 1); /* Read a record */ 00366 else /* else previous ADVANCE='NO' */ 00367 css->u.fmt.leftablim = cup->ulineptr; /* set left tablimit */ 00368 00369 if (errn != 0) 00370 if (errn < 0 ) { 00371 ENDD(endf, css, FERDPEOF); 00372 } 00373 else { 00374 ERROR0(errf, css, errn); 00375 } 00376 cup->pnonadv = css->u.fmt.nonadv; /* remember prev ADVANCE= */ 00377 00378 /* ************************************************************************** 00379 * Data Transfer Section 00380 ************************************************************************* */ 00381 00382 #if defined(__mips) || !defined(_WORD32) 00383 if (!(cup->uft90)) { 00384 errn = _rnl90to77(css, cup, namlist, stck, errf, endf); 00385 goto finalization; 00386 00387 } 00388 #endif 00389 skiprec: 00390 while (cup->ulinecnt == 0) { 00391 errn = _nlrd_fillrec(css, cup); 00392 if (errn != 0) 00393 goto err_eof; 00394 } 00395 rrd: 00396 do { 00397 CMTE_MAINGT(c) 00398 } while (ISBLANK(c)); 00399 if (c != '&' && c != '$') { 00400 /* irix f77 and f90, and 'assign -Y on' skip an input 00401 * record when the first part of the record is not an 00402 * ampersand or dollar sign delimiting a namelist 00403 * group name. 00404 */ 00405 if ((cup->ufnl_skip != 0) || 00406 (cup->ufcompat == AS_IRIX_F77) || 00407 (cup->ufcompat == AS_IRIX_F90)) { 00408 cup->ulinecnt = 0; 00409 goto skiprec; 00410 } 00411 errn = FENLONEC; 00412 ERROR0(errf, css, errn); 00413 } 00414 /* save beginning character to check against ending char */ 00415 endnmlchar = c; 00416 00417 /* get first character of namelist group name from input record */ 00418 MAINGT(c); 00419 /* and get namelist group name from input record */ 00420 errn = _getname(css, cup, buf, &c); 00421 if (errn != 0) 00422 goto err_eof; 00423 /* convert group name to uppercase */ 00424 _cnvrt_toupper(buf); 00425 00426 assert ( (cup != NULL)); 00427 rcount = namlist->icount; /* number of name table entries */ 00428 rptr = _fcdtocp(namlist->group_name); /* ptr to groupname */ 00429 rlen = _fcdlen(namlist->group_name); /* len of groupname */ 00430 nlvar = namlist->goli; /* group object ptr */ 00431 00432 if (strncmp(rptr,buf,rlen)) { 00433 if (cup->ufnl_skip == 0) { 00434 errn = FENLIVGP; 00435 ERROR1(errf, css, errn, buf); 00436 } 00437 00438 /* Skip unmatched namelist group. The slash terminates 00439 * the f90 namelist input. 00440 */ 00441 while (c != '/') { 00442 00443 /* check to see if old namelist ending (&END) 00444 * is present rather than the slash in f90. 00445 */ 00446 if (c == '&' || c == '$') { 00447 00448 /* check to see that beginning namelist 00449 * group name delimiter matches the 00450 * ending delimiter before END. 00451 */ 00452 if (c == endnmlchar) { 00453 00454 /* get END, if present. */ 00455 do { 00456 MAINGT(c); 00457 } while (!ISBLANK(c)); 00458 goto rrd; 00459 } 00460 } 00461 00462 /* check for delimited character string */ 00463 if ((c == '\'') || (c == '"')) { 00464 char qcr; 00465 qcr = c; 00466 rqte: 00467 do { 00468 MAINGT(c); 00469 } while (c != qcr); 00470 MAINGT(c); 00471 /* embedded double quote? */ 00472 if (c == qcr) 00473 goto rqte; 00474 } else { 00475 CMTE_MAINGT(c); 00476 } 00477 } 00478 00479 goto rrd; 00480 } 00481 /* 00482 * This is the correct namelist group name. Process the 00483 * input record. Read until the input record or records 00484 * until the terminating character is found. This is a 00485 * slash or ampersand or MRNLDELIM. 00486 */ 00487 while (c != '/') { 00488 int sepcnt; 00489 if (c == '&' || c == '$') { 00490 if (c != endnmlchar) { 00491 /* begin character did not match end char */ 00492 errn = FENLONEC; 00493 ERROR0(errf, css, errn); 00494 } 00495 else 00496 goto finalization; 00497 } 00498 /* get group_object_name from input record */ 00499 errn = _getname(css, cup, buf, &c); 00500 if (errn != 0) 00501 goto err_eof; 00502 _cnvrt_toupper(buf); 00503 /* find matching group_object_name from namelist table */ 00504 if (!(fdvar = _findname(buf, nlvar, rcount))) { 00505 if (strlen(buf) > 0) { 00506 /* An objectlistname in input record */ 00507 errn = FENLNREC; 00508 ERROR1(errf, css, errn, buf); 00509 } 00510 else { 00511 /* No object list name in input record */ 00512 errn = 0; /* empty variable entry */ 00513 goto finalization; 00514 } 00515 } 00516 /* 00517 * c is a '%' to indicate a structure component follows. 00518 * Look for a component name to follow the percent sign. 00519 */ 00520 while (c == '%') { 00521 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 00522 unsigned scount; 00523 nmlist_goli_t *vaddr; 00524 assert ((fdvar->valtype == IO_STRUC_A) || 00525 (fdvar->valtype == IO_STRUC_S)); 00526 if ((fdvar->valtype == IO_SCALAR) || 00527 (fdvar->valtype == IO_DOPEVEC)) { 00528 /* structure indicator in object name 00529 * that is not a structure 00530 */ 00531 errn = FENLNREC; 00532 ERROR1(errf, css, errn, buf); 00533 } 00534 /* input variable is a structure */ 00535 nlstruc = fdvar->goli_addr.sptr; /* ptr to struc */ 00536 vaddr = nlstruc->goli; /* ptr to list */ 00537 scount = nlstruc->structlen; /* number entries */ 00538 /* 00539 * Get the namelist object list name from the 00540 * input record 00541 */ 00542 MAINGT(c); 00543 errn = _getname(css, cup, buf, &c); 00544 if (errn != 0) 00545 goto err_eof; 00546 _cnvrt_toupper(buf); 00547 /* 00548 * Find the matching namelist object list name 00549 * for the object list name in the input record 00550 */ 00551 if (!(fdvar = _findname(buf, vaddr, scount))) { 00552 if (strlen(buf) > 0) { 00553 /* objectlistname in input record */ 00554 errn = FENLNREC; 00555 ERROR1(errf, css, errn, buf); 00556 } 00557 else { 00558 /* No name in input record */ 00559 errn = 0; /* empty variable entry */ 00560 goto finalization; 00561 } 00562 } 00563 } 00564 /* we're positioned just after the object name 00565 * so get following value(s) 00566 */ 00567 errn = _getnlval(css, fdvar, &c, cup); 00568 if (errn != 0) 00569 goto err_eof; 00570 sepcnt = 0; 00571 for ( ; ; ) { 00572 if (!(ISBLANK(c))) { 00573 if ((c == ',') && (sepcnt == 0)) { 00574 /* skip separator */ 00575 sepcnt++; 00576 } 00577 else 00578 break; 00579 } 00580 CMTE_MAINGT(c); 00581 } 00582 } 00583 00584 /*************************************************************************** 00585 * Statement Finalization Section 00586 ***************************************************************************/ 00587 finalization: 00588 00589 /* Set IOSTAT variable to 0 if no error, >0 error code otherwise */ 00590 if (cilist->iostat_spec != NULL) 00591 *cilist->iostat_spec = errn; 00592 00593 /* End the Beguine */ 00594 STMT_END(cup, TF_READ, NULL, css); /* Unlock unit */ 00595 00596 /* Return proper status */ 00597 if (errn == 0) 00598 return(IO_OKAY); 00599 else if (errn < 0) { 00600 cup->pnonadv = 0; /* no current record if EOF */ 00601 return(IO_END); 00602 } 00603 return(IO_ERR); 00604 err_eof: 00605 /* err and eof handling */ 00606 if(errn < 0) { 00607 ENDD(endf, css, FERDPEOF); 00608 } else if (errn == FENLSTRN || errn == FENLSTRG || 00609 errn == FENLSUBD || errn == FENLSUBN || 00610 errn == FENLSUBS || errn == FENLLGNM || 00611 errn == FENLUNKI || errn == FENLUNKN) { 00612 ERROR1(errf, css, errn, buf); 00613 } else { 00614 ERROR0(errf, css, errn); 00615 } 00616 goto finalization; 00617 } 00618 00619 /* _nlrd_fillrec - namelist read of one record from a file 00620 * returns 0 - successful 00621 * EOF - end of file 00622 * ERR - error was encountered 00623 * cup->uend is set if EOF encountered 00624 */ 00625 00626 static int 00627 _nlrd_fillrec(FIOSPTR css, unit *cup) 00628 { 00629 register int errn; 00630 00631 errn = css->u.fmt.endrec(css, cup, 1); 00632 00633 return(errn); 00634 } 00635 00636 /* 00637 * _getname - Get variable name or group name 00638 * 00639 * On entry: 00640 * - Positioned to a name possibly preceded by blanks 00641 * On exit: 00642 * - 0 if successful 00643 * EOF if end of file read 00644 * > 0 if other error (errno will be set) 00645 * - *cup->ulineptr is record position after the name. 00646 * - *lastc contains the last character read. 00647 * In looking for the name, we stop when we see a space, '=', 00648 * '(', '%', or ending namelist delimiter ('&' or '$'). 00649 */ 00650 00651 static int 00652 _getname(FIOSPTR css, unit *cup, char *s, char *lastc) 00653 { 00654 char *p, c; 00655 int n, errn; 00656 errn = 0; 00657 n = MAXNAML + 5; /* real*16 input can be 34 characters long */ 00658 p = s; 00659 c = *lastc; 00660 /* 00661 * Names cannot have embedded blanks. In cf77 compatibility mode, 00662 * a comment can immediately follow the name and terminates it. 00663 * An unknown comment character may be nonstandard for Fortran 90. 00664 * Allow the terminating ampersand for simpler non-f90 namelist 00665 * compatibility. 00666 */ 00667 00668 while (ISBLANK(c)) 00669 CMTE_SUBGTC(c); 00670 while (!(ISBLANK(c)) && c != '(' && c != '=' && c != '/' && 00671 c != '&' && c != '%' && c != '$') { 00672 *p++ = c; 00673 CMTE_SUBGTCNOEOR(c); 00674 if (n-- == 0) { 00675 errn = FENLLGNM; /* name too long */ 00676 p--; 00677 break; 00678 } 00679 } 00680 *lastc = c; 00681 *p = '\0'; 00682 return (errn); 00683 } 00684 00685 /* 00686 * _findname - find variable name in list of nmlist_goli_t entries 00687 * of namelist table 00688 * On entry: 00689 * - lastc points to character following name in input buffer. 00690 * Returns: 00691 * pointer to matching object list entry 00692 * NULL if variable name was not found. 00693 */ 00694 00695 static nmlist_goli_t 00696 *_findname(char *key, nmlist_goli_t *nlvar, unsigned countitm) 00697 { 00698 char *varptr; 00699 unsigned varlen; 00700 nmlist_goli_t *newitem; 00701 int cnt, lcnt; 00702 newitem = nlvar; 00703 cnt = countitm; 00704 lcnt = strlen(key); 00705 while (cnt--) { 00706 varptr = _fcdtocp(newitem->goli_name); 00707 varlen = _fcdlen(newitem->goli_name); 00708 if ((varlen == lcnt) && (!strncmp(key, varptr, lcnt))) 00709 return (newitem); 00710 else { 00711 /* cannot do this in a switch since some word32 00712 * systems do not have the extra padding. 00713 */ 00714 #if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64)) 00715 newitem = (nmlist_goli_t*)((long *)newitem + 00716 3 + (sizeof(_fcd))/(sizeof(long))); 00717 #else 00718 newitem = (nmlist_goli_t*)((long *)newitem + 00719 2 + (sizeof(_fcd))/(sizeof(long))); 00720 #endif 00721 } 00722 } 00723 return (NULL); 00724 } 00725 00726 /* _getnlval - get values for namelist io 00727 * 00728 * On entry: 00729 * - positioned after variable name 00730 * - lastc contains the character following the name 00731 * On exit: 00732 * - *lastc contains the character following the value 00733 * - cup->ulineptr is pointing to the character following lastc 00734 * - returns: 0 if successful 00735 * -value if EOF detected 00736 * > 0 if error detected 00737 */ 00738 00739 static int 00740 _getnlval(FIOSPTR css, nmlist_goli_t *nlvar, char *lastc, unit *cup) 00741 { 00742 long cntp = 0; 00743 int i; 00744 int ndim = 0; 00745 int encnt = 0; 00746 int icnt = 0; 00747 long strbegend[3]; 00748 char *cp; 00749 char c; 00750 long vaddr; 00751 long errn = 0; 00752 struct DvDimen dimnsn[MAXDIM]; 00753 struct DvDimen *dvdn = dimnsn; 00754 /* find offset if indexed array */ 00755 /* clear array element, section, and substring information */ 00756 for (i=0; i < MAXDIM; i++) { 00757 dimnsn[i].stride_mult = 0; 00758 dimnsn[i].extent = 0; 00759 dimnsn[i].low_bound = 0; 00760 } 00761 strbegend[0] = -1; /* flag indicating string */ 00762 strbegend[1] = -1; /* string begin */ 00763 strbegend[2] = -1; /* string end */ 00764 00765 switch (nlvar->valtype) { 00766 case IO_SCALAR: 00767 { 00768 nmlist_scalar_t *nlscalar; /* nmlist scalar entry */ 00769 unsigned long elsize; 00770 unsigned int int_len; 00771 void *vaddr; 00772 ftype_t type; /* fortran data type */ 00773 nlscalar = nlvar->goli_addr.ptr; /* ptr to scalar */ 00774 type = nlscalar->tinfo.type; 00775 int_len = nlscalar->tinfo.int_len; 00776 /* Assertions */ 00777 assert (type >= DVTYPE_TYPELESS && type <= DVTYPE_ASCII); 00778 assert(nlscalar->tinfo.int_len > 0 ); 00779 if ((type != DVTYPE_ASCII) && (*lastc == '(')) { 00780 errn = FENLUNKI; 00781 break; 00782 } 00783 if (type == DVTYPE_ASCII) 00784 strbegend[0] = 0; 00785 if (*lastc == '(') { 00786 errn = _indx_nl(css, cup, dvdn, &ndim, strbegend, 00787 &encnt, &icnt, 0); 00788 if (errn != 0) { 00789 if (errn == FENLSUBS) 00790 errn = FENLSTRG; 00791 else if (errn == FENLSUBN) 00792 errn = FENLSTRN; 00793 break; 00794 } 00795 } else { 00796 while (ISBLANK(*lastc)) { 00797 CMTE_SUBGTC(*lastc); 00798 } 00799 /* namelist is terminated by slash, ampersand, or $ */ 00800 if ((*lastc == '/') || (*lastc == '&') || (*lastc == '$')) { 00801 errn = 0; 00802 break; 00803 } 00804 /* Not a value here. */ 00805 if (*lastc != '=') { 00806 errn = FENLNOVL; 00807 break; 00808 } 00809 } 00810 00811 /* Currently positioned after the '=' sign, but lastc is 00812 * pointing at the '=' sign. Update lastc for nlread and 00813 * compute: 00814 * cntp = number of array elements to be read 00815 * (1 if not an array). 00816 * elsize = size of a variable or array element 00817 * (words for nonchar, bytes for char). 00818 * vaddr = target address for input value. For character, 00819 * this is a Fortran character descriptor. 00820 */ 00821 CMTE_SUBGTC(*lastc); 00822 if (type == DVTYPE_ASCII) { 00823 char *wptr; 00824 const int bytesperchar = 1; 00825 long begt = strbegend[1]; 00826 long endt = strbegend[2]; 00827 wptr = _fcdtocp(nlscalar->scal_addr.charptr); 00828 elsize = _fcdlen(nlscalar->scal_addr.charptr); 00829 elsize = elsize * bytesperchar; 00830 /* check for character substrings in input record */ 00831 if (strbegend[0] > 0) { 00832 if (begt < 1 ) 00833 begt = 1; 00834 else if (begt > elsize) { 00835 errn = FENLUNKN; 00836 break; 00837 } 00838 if (endt < 1 ) 00839 endt = elsize; 00840 else if ((endt > elsize) || (endt < begt)) { 00841 errn = FENLUNKN; 00842 break; 00843 } 00844 wptr = wptr + (begt - 1); 00845 elsize = (endt - begt) + 1; 00846 } 00847 vaddr = wptr; 00848 } 00849 else { 00850 vaddr = nlscalar->scal_addr.ptr; 00851 elsize = int_len >> 3; 00852 } 00853 c = *lastc; 00854 cntp = 1; 00855 errn = _nlread(css, type, cup, vaddr, elsize, cntp, 0, &c); 00856 *lastc = c; 00857 break; 00858 } 00859 case IO_DOPEVEC: 00860 { 00861 DopeVectorType *nldv; 00862 ftype_t type; /* fortran data type */ 00863 nldv = nlvar->goli_addr.dv; /* ptr to dope vector */ 00864 /* Assertions */ 00865 assert ( nldv != NULL ); 00866 assert ( nldv->type_lens.int_len > 0 ); 00867 type = nldv->type_lens.type; 00868 if (type == DVTYPE_ASCII) 00869 strbegend[0] = 0; 00870 for (i=0; i < nldv->n_dim; i++) { 00871 dimnsn[i].stride_mult = nldv->dimension[i].stride_mult; 00872 dimnsn[i].extent = nldv->dimension[i].extent; 00873 dimnsn[i].low_bound = nldv->dimension[i].low_bound; 00874 } 00875 if (*lastc == '(') { 00876 errn = _indx_nl(css, cup, dvdn, &ndim, strbegend, 00877 &encnt, &icnt, 1); 00878 if (errn != 0) 00879 break; 00880 } else { 00881 while (ISBLANK(*lastc)) { 00882 CMTE_SUBGTC(*lastc); 00883 } 00884 /* namelist is terminated by slash, ampersand, or $ */ 00885 if ((*lastc == '/') || (*lastc == '&') || (*lastc == '$')) { 00886 errn = 0; 00887 break; 00888 } 00889 /* Not a value or structure qualification here. */ 00890 if (*lastc != '=') { 00891 errn = FENLNOVL; 00892 break; 00893 } 00894 } 00895 00896 /* Currently positioned after the '=' sign, but lastc is 00897 * pointing at the '=' sign. Update lastc for nlread and 00898 * compute: 00899 * cntp = number of array elements to be read 00900 * (1 if not an array). 00901 * elsize = size of a variable or array element 00902 * (words for nonchar, bytes for char). 00903 * vaddr = target address for input value. For character, 00904 * this is a Fortran character descriptor. 00905 */ 00906 CMTE_SUBGTC(*lastc); 00907 if ((ndim != 0) && (ndim != nldv->n_dim)) { 00908 errn = FENLBNDY; 00909 break; 00910 } 00911 00912 /* call nlread directly for array elements. */ 00913 if (ndim != 0) { 00914 struct DvDimen *dvdm = nldv->dimension; 00915 void *vaddr; 00916 long extent = 1; 00917 long elsize; 00918 long mult = 1; 00919 long offs = 0; 00920 long incrmt; 00921 int int_len = nldv->type_lens.int_len; 00922 register long nc; 00923 for (nc = 0; nc < nldv->n_dim; nc++) { 00924 extent *= dvdm[nc].extent; 00925 } 00926 00927 /* array element. */ 00928 if (encnt == 0 && icnt == 0) { 00929 offs = dimnsn[0].low_bound - (dvdm[0].low_bound); 00930 incrmt = 1; 00931 for (nc = 1; nc < ndim; nc++) { 00932 mult = mult * (dvdm[nc-1].extent); 00933 offs = offs + 00934 ((dimnsn[nc].low_bound - 00935 dvdm[nc].low_bound) * mult); 00936 } 00937 extent = extent - offs; 00938 if (type == DVTYPE_ASCII) { 00939 char *wptr; 00940 const int bytesperchar = 1; 00941 long begt = strbegend[1]; 00942 long endt = strbegend[2]; 00943 wptr = 00944 _fcdtocp(nldv->base_addr.charptr); 00945 elsize = 00946 _fcdlen(nldv->base_addr.charptr); 00947 elsize = elsize * bytesperchar; 00948 /* check for character 00949 * substrings in input record. 00950 */ 00951 wptr += offs * elsize; 00952 00953 if (strbegend[0] > 0) { 00954 if (begt < 1 ) 00955 begt = 1; 00956 else if (begt > elsize) { 00957 errn = FENLUNKN; 00958 break; 00959 } 00960 if (endt < 1 ) 00961 endt = elsize; 00962 else if ((endt > 00963 elsize) || 00964 (endt < begt)) { 00965 errn = FENLUNKN; 00966 break; 00967 } 00968 wptr = wptr + (begt - 1); 00969 elsize = (endt - begt) + 1; 00970 } 00971 00972 vaddr = wptr; 00973 } else { 00974 bcont *iwptr; 00975 iwptr = (bcont*)nldv->base_addr.a.ptr; 00976 elsize = int_len >> 3; 00977 iwptr += offs * (elsize / 00978 (sizeof(bcont))); 00979 vaddr = iwptr; 00980 } 00981 /* Assertions */ 00982 assert ( elsize > 0 && extent > 0 ); 00983 c = *lastc; 00984 cntp = extent; 00985 errn = _nlread(css, type, cup, vaddr, 00986 elsize, cntp, incrmt, &c); 00987 *lastc = c; 00988 } else { 00989 for (nc = 0; nc < ndim; nc++) { 00990 if (dimnsn[nc].extent != 00991 dvdm[nc].extent) { 00992 if (dimnsn[nc].extent > 00993 dvdm[nc].extent) { 00994 return(FENLBNDY); 00995 } 00996 } 00997 if (dimnsn[nc].stride_mult != 00998 dvdm[nc].stride_mult) { 00999 dimnsn[nc].stride_mult = 01000 dimnsn[nc].stride_mult * 01001 dvdm[nc].stride_mult; 01002 } 01003 } 01004 c = *lastc; 01005 errn = _nl_stride_dv(css, cup, nldv, 01006 dvdn, &c, strbegend); 01007 *lastc = c; 01008 } 01009 01010 /* call nlread directly for noncharacter whole arrays */ 01011 } else if (type != DVTYPE_ASCII) { 01012 int n_dm = nldv->n_dim; 01013 unsigned long elsize = nldv->type_lens.int_len >> 3; 01014 unsigned long extent = nldv->dimension[0].extent; 01015 struct DvDimen *dvdm = nldv->dimension; 01016 long incrmt; 01017 01018 if (n_dm != 1) { 01019 register long nc; 01020 if (n_dm == 2) { 01021 if (dvdm[0].stride_mult * extent != 01022 dvdm[1].stride_mult) 01023 goto gen_dv_process; 01024 extent *= dvdm[1].extent; 01025 } else if (n_dm == 0) { 01026 extent = 1; 01027 } else { 01028 for (nc = 0; nc < (n_dm-1); nc++) { 01029 register int st = 01030 dvdm[nc].stride_mult; 01031 register int ex = 01032 dvdm[nc].extent; 01033 if ( (st * ex) != 01034 dvdm[nc+1].stride_mult) 01035 goto gen_dv_process; 01036 extent *= dvdm[nc+1].extent; 01037 } 01038 } 01039 } 01040 if (extent > 1) { 01041 register long sm = 01042 nldv->dimension[0].stride_mult; 01043 if (sm * (signed)SMSCALE(nldv) == elsize) 01044 incrmt = 1; 01045 else { 01046 int bytes_per_sm = sm * 01047 (signed)SMSCALE(nldv); 01048 incrmt = bytes_per_sm / elsize; 01049 /* if stride not a multiple of size... */ 01050 if (elsize * incrmt != bytes_per_sm) 01051 goto gen_dv_process; 01052 } 01053 } else 01054 incrmt = 0; 01055 01056 /* Assertions */ 01057 assert ( elsize > 0 && extent > 0 ); 01058 c = *lastc; 01059 errn = _nlread(css, type, cup, 01060 nldv->base_addr.a.ptr, elsize, extent, 01061 incrmt, &c); 01062 *lastc = c; 01063 } else { 01064 gen_dv_process: 01065 c = *lastc; 01066 errn = _nl_stride_dv(css, cup, nldv, 0, &c, strbegend); 01067 *lastc = c; 01068 } 01069 break; 01070 } 01071 case IO_STRUC_A: 01072 { 01073 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 01074 unsigned long elsize; 01075 unsigned int int_len; 01076 unsigned int scount; 01077 char *cp; 01078 nmlist_goli_t *vaddr; 01079 ftype_t type; /* fortran data type */ 01080 int byt = 0; /* scalar struct has 0 offset */ 01081 nlstruc = nlvar->goli_addr.sptr; /* ptr to structure. */ 01082 vaddr = nlstruc->goli; /* ptr to list. */ 01083 scount = nlstruc->structlen; /* number of entries. */ 01084 if (*lastc == '(') { 01085 /* This is not an array or substring - err */ 01086 errn = FENLUNKI; 01087 break; 01088 } else { 01089 while (ISBLANK(*lastc)) { 01090 CMTE_SUBGTC(*lastc); 01091 } 01092 /* namelist terminated by slash, ampersand, or $ */ 01093 if ((*lastc == '/') || (*lastc == '&') || 01094 (*lastc == '$')) { 01095 errn = 0; 01096 break; 01097 } 01098 /* Check for structure qualification. */ 01099 if (*lastc == '%') { 01100 errn = FENLIOER; 01101 break; 01102 } else if (*lastc != '=') { 01103 errn = FENLNOVL; 01104 break; 01105 } 01106 } 01107 01108 /* Currently positioned after the '=' sign, but lastc is 01109 * pointing at the '=' sign. Update lastc for nlread and 01110 * compute: 01111 * cntp = number of array elements to be read 01112 * (1 if not an array). 01113 * elsize = size of a variable or array element 01114 * (words for nonchar, bytes for char). 01115 * vaddr = target address for input value. For character, 01116 * this is a Fortran character descriptor. 01117 */ 01118 CMTE_SUBGTC(*lastc); 01119 cp = lastc; 01120 errn = _nlrdent(css, cup, vaddr, scount, cp, byt); 01121 *lastc = *cp; 01122 break; 01123 } 01124 case IO_STRUC_S: 01125 { 01126 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 01127 unsigned long elsize; 01128 unsigned int int_len; 01129 unsigned int scount; 01130 int nc; 01131 long ic; 01132 char *cp; 01133 long extnt = 1; 01134 nmlist_goli_t *vaddr; 01135 DopeVectorType *nlsdv; 01136 ftype_t type; /* fortran data type */ 01137 int byt = 0; /* arraystruct offset in bytes */ 01138 unsigned int compflag = 0; 01139 nmlist_goli_t *fdvar; 01140 char abuf[MAXNAML + 5]; 01141 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 01142 01143 /* number of entries */ 01144 scount = nlstruc->structlen; 01145 01146 /* ptr to list */ 01147 vaddr = nlstruc->goli; 01148 fdvar = nlvar; 01149 01150 /* ptr to dope vector */ 01151 nlsdv = nlstruc->struc_addr.dv; 01152 elsize = nlsdv->base_addr.a.el_len; 01153 type = nlsdv->type_lens.type; 01154 01155 for (i=0; i < nlsdv->n_dim; i++) { 01156 dimnsn[i].stride_mult = nlsdv->dimension[i].stride_mult; 01157 dimnsn[i].extent = nlsdv->dimension[i].extent; 01158 dimnsn[i].low_bound = nlsdv->dimension[i].low_bound; 01159 } 01160 if (*lastc == '(') { 01161 errn = _indx_nl(css, cup, dvdn, &ndim, strbegend, 01162 &encnt, &icnt, 1); 01163 if (errn != 0) 01164 break; 01165 } else { 01166 while (ISBLANK(*lastc)) { 01167 CMTE_SUBGTC(*lastc); 01168 } 01169 /* namelist terminated by slash, ampersand, or $ */ 01170 if ((*lastc == '/') || (*lastc == '&') || 01171 (*lastc == '$')) { 01172 errn = 0; 01173 break; 01174 } 01175 } 01176 01177 /* Currently positioned after the '=' sign, but lastc is 01178 * pointing at the '=' sign. Update lastc for nlread and 01179 * compute: 01180 * cntp = number of array elements to be read 01181 * (1 if not an array). 01182 * elsize = size of a variable or array element 01183 * (words for nonchar, bytes for char). 01184 * vaddr = target address for input value. For character, 01185 * this is a Fortran character descriptor. 01186 * 01187 * byt is used when the structure is an array of 01188 * structures. Each component must add an offset to 01189 * its base address after the first array element. 01190 * With derived types, the bits must be changed to bytes. 01191 */ 01192 CMTE_SUBGTC(*lastc); 01193 if ((ndim != 0) && (ndim != nlsdv->n_dim)) { 01194 errn = FENLBNDY; 01195 break; 01196 } 01197 /* Check for structure qualification. */ 01198 while (*lastc == '%') { 01199 compflag++; 01200 nlstruc = fdvar->goli_addr.sptr; 01201 vaddr = nlstruc->goli; 01202 scount = nlstruc->structlen; 01203 /* Check for structure qualification. */ 01204 SUBGTC(*lastc); 01205 errn = _getname(css, cup, abuf, lastc); 01206 if (errn != 0) 01207 break; 01208 _cnvrt_toupper(abuf); 01209 /* find matching namelist object list 01210 * name in input record 01211 */ 01212 if (!(fdvar = _findname(abuf, vaddr, scount))) { 01213 if (strlen(abuf) > 0) { 01214 /* objectlistname in record */ 01215 errn = FENLNREC; 01216 break; 01217 } else { 01218 /* no name in record. May be 01219 * empty record. Quit process. 01220 */ 01221 errn = 0; 01222 break; 01223 } 01224 } else 01225 vaddr = fdvar; 01226 while (ISBLANK(*lastc)) { 01227 CMTE_SUBGTC(*lastc); 01228 } 01229 if (*lastc != '=') { 01230 errn = FENLNOVL; 01231 break; 01232 } 01233 CMTE_SUBGTC(*lastc); 01234 } 01235 if (ndim != 0) { 01236 struct DvDimen *dvdm = nlsdv->dimension; 01237 long mult = 1; 01238 long offs = 0; 01239 register long nc; 01240 for (nc = 0; nc < nlsdv->n_dim; nc++) 01241 extnt *= nlsdv->dimension[nc].extent; 01242 /* array element. */ 01243 if (encnt == 0 && icnt == 0) { 01244 offs = dimnsn[0].low_bound - (dvdm[0].low_bound); 01245 for (nc = 1; nc < ndim; nc++) { 01246 mult = mult * (dvdm[nc-1].extent); 01247 offs = offs + 01248 ((dimnsn[nc].low_bound - 01249 dvdm[nc].low_bound) * mult); 01250 } 01251 extnt = extnt - offs; 01252 elsize = elsize >> 3; 01253 byt = offs * elsize; 01254 assert ( elsize > 0 && extnt > 0); 01255 cp = lastc; 01256 if (compflag) 01257 scount = 1; 01258 errn = _nlrdent(css, cup, vaddr, scount, 01259 cp, byt); 01260 *lastc = *cp; 01261 } else { 01262 for (nc = 0; nc < ndim; nc++) { 01263 if (dimnsn[nc].extent != 01264 dvdm[nc].extent) { 01265 if (dimnsn[nc].extent > 01266 dvdm[nc].extent) { 01267 return(FENLBNDY); 01268 } 01269 } 01270 if (dimnsn[nc].stride_mult != 01271 dvdm[nc].stride_mult) { 01272 dimnsn[nc].stride_mult = 01273 dimnsn[nc].stride_mult * 01274 dvdm[nc].stride_mult; 01275 } 01276 } 01277 cp = lastc; 01278 if (compflag) 01279 scount = 1; 01280 errn = _nl_strd_derv(css, cup, nlsdv, dvdn, 01281 cp, vaddr, scount, byt); 01282 *lastc = *cp; 01283 } 01284 } else { 01285 cp = lastc; 01286 errn = _nl_strd_derv(css, cup, nlsdv, 0, cp, 01287 vaddr, scount, byt); 01288 *lastc = *cp; 01289 } 01290 break; 01291 } 01292 default: 01293 errn = FEINTUNK; 01294 } 01295 return(errn); 01296 } 01297 01298 /* _nlread - calls _nexdata to get the next value and stores the 01299 * result in the namelist object entry. 01300 * On Entry - cup_ulineptr points to the first character following the 01301 * value. 01302 * On Exit - lastc will contain the first nonblank, nonseparator 01303 * character following the value. 01304 */ 01305 01306 static int 01307 _nlread(FIOSPTR css, ftype_t type, unit *cup, void *ptr, long elsize, 01308 int cntp, int incrm, char *lastc) 01309 { 01310 long ss, ncntp; 01311 long stat; 01312 char c; 01313 void *vaddr; 01314 long errn = 0; 01315 int lcount; /* repeat count for values */ 01316 long lval[9]; /* convert space */ 01317 bcont *sval; 01318 int nullvlu; 01319 c = *lastc; 01320 ncntp = cntp; 01321 vaddr = ptr; 01322 nullvlu = 0; 01323 01324 while (ncntp > 0) { 01325 errn = _nexdata(css, type, vaddr, ncntp, 1, c, cup, 01326 lval, &lcount, elsize, &nullvlu); 01327 if (errn != 0) 01328 return(errn); 01329 else { 01330 if (nullvlu == 2) { 01331 lcount = 0; 01332 ncntp = 0; 01333 } 01334 } 01335 if (lcount > ncntp) { 01336 errn = FENLTOOM; 01337 return(errn); 01338 } 01339 if (type == DVTYPE_ASCII) { 01340 char *wptr; 01341 wptr = vaddr; 01342 /* character data already stored, adjust 01343 * ptr and count only. 01344 */ 01345 ncntp = ncntp - lcount; 01346 wptr = wptr + (lcount * elsize); 01347 vaddr = wptr; 01348 } 01349 else { 01350 int move; 01351 int *iptr; 01352 int ix, lim; 01353 bcont *siptr; 01354 move = MIN(ncntp,lcount); 01355 lim = elsize/(sizeof(bcont)); 01356 siptr = (bcont*) vaddr; 01357 /* move what's needed from data group */ 01358 while (move != 0) { 01359 sval = (bcont*) lval; 01360 /* do not move null values */ 01361 if (!nullvlu) { 01362 for (ix=0; ix < lim; ix++) { 01363 *siptr = *sval; 01364 siptr++; 01365 sval++; 01366 } 01367 } else 01368 siptr = siptr + lim; 01369 vaddr = siptr; 01370 move--; 01371 ncntp--; 01372 lcount--; 01373 } 01374 } 01375 do { 01376 CMTE_SUBGTC(*lastc); 01377 } while (ISBLANK(*lastc)); 01378 if (*lastc == ',') { 01379 do { 01380 CMTE_SUBGTC(*lastc); 01381 } while (ISBLANK(*lastc)); 01382 } 01383 c = *lastc; 01384 } 01385 return(0); 01386 } 01387 01388 /* _indx_nl compute the dimension information of an 01389 * indexed array in the input record. 01390 * On entry: 01391 * _ positioned just after the '(' 01392 * On exit: 01393 * - returns: 0 on success 01394 * -value on eof 01395 * - positioned just after the '=' 01396 * - if % occurred, the scan is backed up one 01397 * - the lastc argument is not changed 01398 */ 01399 01400 static int 01401 _indx_nl( 01402 FIOSPTR css, unit *cup, struct DvDimen *dvdn, int *ndima, 01403 long strbegend[3],int *encnt, int *icnt, int arryflag) 01404 { 01405 long mode, ss; 01406 long offs, mult; 01407 char c; 01408 int i, j, ir1, en1; 01409 long dummy; 01410 int errn = 0; 01411 long stat; 01412 long field_width; 01413 long *field_begin; 01414 long *field_end; 01415 long tempbuf[2]; 01416 en1 = 0; 01417 ir1 = 0; 01418 if (arryflag) { 01419 for (i = 0; i < MAXDIMS; ) { 01420 long dummy; 01421 /* no comments in namelist input here and 01422 * skip leading blanks here only. 01423 */ 01424 do { 01425 SUBGTC(c); 01426 } while (ISBLANK(c)); 01427 /* Was end of subscripts reached in input record */ 01428 if (c == ')') 01429 break; 01430 cup->ulinecnt++; 01431 cup->ulineptr--; 01432 01433 /* Get the low_bound subscript information first */ 01434 GETSECTION(c); 01435 if (field_width == 0) 01436 goto indxgetext; 01437 /* pass field_end + 1 */ 01438 field_end++; 01439 tempbuf[0] = 0; 01440 tempbuf[1] = 0; 01441 mode = 0; 01442 (void) _iu2s(field_begin, &field_width, 01443 &field_end, &mode, tempbuf, &stat, 01444 &dummy, &dummy); 01445 if(stat < 0) { 01446 errn = FENLSUBS; 01447 return(errn); 01448 } 01449 dvdn[i].low_bound = *((_f_int8 *)tempbuf); 01450 indxgetext: 01451 /* point beyond subscript or lowbound. */ 01452 cup->ulineptr = field_begin + field_width; 01453 cup->ulinecnt = cup->ulinecnt - field_width; 01454 01455 /* Get extent subscript information */ 01456 if (c == ':') { 01457 /* update ulineptr */ 01458 SUBGTC(c); 01459 GETSECTION(c); 01460 if (field_width == 0) 01461 goto indxgetinc; 01462 /* pass field_end + 1 */ 01463 field_end++; 01464 tempbuf[0] = 0; 01465 tempbuf[1] = 0; 01466 mode = 0; 01467 (void) _iu2s(field_begin, &field_width, 01468 &field_end, &mode, tempbuf, &stat, 01469 &dummy, &dummy); 01470 if(stat < 0) { 01471 errn = FENLSUBS; 01472 return(errn); 01473 } 01474 /* calculate extent from upper bound 01475 * (upperbound - lowerbound) + 1 01476 */ 01477 dvdn[i].extent = (*((_f_int8 *)tempbuf) - 01478 dvdn[i].low_bound) + 1; 01479 en1++; 01480 indxgetinc: 01481 /* point beyond subscript extent. */ 01482 cup->ulineptr = field_begin + field_width; 01483 cup->ulinecnt = cup->ulinecnt - field_width; 01484 01485 /* Get stride_mult subscript information */ 01486 if (c == ':') { 01487 /* update ulineptr */ 01488 SUBGTC(c); 01489 GETSECTION(c); 01490 if (field_width == 0) 01491 goto indxforloop; 01492 /* pass field_end + 1 */ 01493 field_end++; 01494 tempbuf[0] = 0; 01495 tempbuf[1] = 0; 01496 mode = 0; 01497 (void) _iu2s(field_begin, 01498 &field_width, &field_end, 01499 &mode, tempbuf, &stat, 01500 &dummy, &dummy); 01501 if(stat < 0) { 01502 errn = FENLSUBS; 01503 return(errn); 01504 } 01505 dvdn[i].stride_mult = *((_f_int8 *)tempbuf); 01506 ir1++; 01507 indxforloop: 01508 /* point beyond subscript stride_mult. */ 01509 cup->ulineptr = field_begin + field_width; 01510 cup->ulinecnt = cup->ulinecnt - field_width; 01511 } 01512 } 01513 /* increment the number of subscripts */ 01514 i++; 01515 do { 01516 SUBGTC(c); /* get to ',' or ')' */ 01517 } while (ISBLANK(c)); /* NO EOR allowed here */ 01518 /* check for end of subscripts */ 01519 if (c == ')') 01520 break; 01521 if (c != ',') { 01522 errn = FENLSUBD; /* Not a comma */ 01523 return(errn); 01524 } 01525 } 01526 *ndima = i; 01527 *encnt = en1; 01528 *icnt = ir1; 01529 if (i == 0) { 01530 errn = FENLSUBN; /* null index */ 01531 return(errn); 01532 } 01533 } 01534 if (strbegend[0] == 0) { 01535 j = 0; 01536 if (arryflag) { 01537 SUBGTC(c); 01538 } else 01539 c = '('; 01540 /* Check for substring information after array element */ 01541 if (c == '(') { 01542 /* skip leading blanks in input here */ 01543 do { 01544 SUBGTC(c); 01545 } while (ISBLANK(c)); 01546 /* End of subscripts found in input record? */ 01547 if (c == ')') { 01548 errn = FENLSTRN; /* null index */ 01549 return(errn); 01550 } 01551 cup->ulinecnt++; 01552 cup->ulineptr--; 01553 GETSECTION(c); 01554 if (field_width == 0) 01555 goto indxstrend; 01556 /* pass field_end + 1 */ 01557 field_end++; 01558 tempbuf[0] = 0; 01559 tempbuf[1] = 0; 01560 mode = 0; 01561 (void) _iu2s(field_begin, &field_width, &field_end, 01562 &mode, tempbuf, &stat, &dummy, &dummy); 01563 if(stat < 0) { 01564 errn = FENLSTRG; 01565 return(errn); 01566 } 01567 strbegend[1] = *((_f_int8 *)tempbuf); 01568 j++; 01569 indxstrend: 01570 /* point beyond colon. */ 01571 cup->ulineptr = field_begin + field_width; 01572 cup->ulinecnt = cup->ulinecnt - field_width; 01573 if (c == ':') { 01574 /* update ulineptr */ 01575 SUBGTC(c); 01576 /* skip leading blanks in input here */ 01577 do { 01578 SUBGTC(c); 01579 } while (ISBLANK(c)); 01580 /* End of subscripts found in input rec */ 01581 if (c == ')') 01582 goto indxstrout; 01583 cup->ulinecnt++; 01584 cup->ulineptr--; 01585 GETSECTION(c); 01586 if (field_width == 0) 01587 goto indxstrdon; 01588 /* pass field_end + 1 */ 01589 field_end++; 01590 tempbuf[0] = 0; 01591 tempbuf[1] = 0; 01592 mode = 0; 01593 (void) _iu2s(field_begin, &field_width, 01594 &field_end, &mode, tempbuf, 01595 &stat, &dummy, &dummy); 01596 if(stat < 0) { 01597 errn = FENLSTRG; 01598 return(errn); 01599 } 01600 strbegend[2] = *((_f_int8 *)tempbuf); 01601 j++; 01602 indxstrdon: 01603 /* point to right paren? */ 01604 cup->ulineptr = field_begin + field_width; 01605 cup->ulinecnt = cup->ulinecnt - field_width; 01606 } 01607 indxstrout: 01608 strbegend[0] = j; 01609 } 01610 } 01611 /* 01612 * Look for the equal sign or the structure qualification 01613 * character 01614 */ 01615 while (!(c == '=') && !(c == '%')) { 01616 SUBGTC(c); 01617 } 01618 if (c == '%') { 01619 cup->ulineptr--; 01620 cup->ulinecnt++; 01621 } 01622 return(errn); 01623 } 01624 01625 /* Converts the string in buf to upper case letters */ 01626 01627 static void 01628 _cnvrt_toupper(char *buf) 01629 { 01630 char c; 01631 while ((c = *buf) != '\0') { 01632 *buf++ = toupper(c); 01633 } 01634 return; 01635 } 01636 01637 /* 01638 * _nlrdent - namelist input of structure entries 01639 * Recursive call to handle structure table entries for 01640 * namelist. 01641 * Return value: 01642 * 0 on success. lval contains result. 01643 * lcount contains repeat count. 01644 * >0 error code if error encountered 01645 */ 01646 01647 static int 01648 _nlrdent(FIOSPTR css, unit *cup, nmlist_goli_t *nalist, unsigned count, 01649 char *lastc, int byt) 01650 { 01651 char c, oc; 01652 int ocnt, ss; 01653 long *optr; 01654 unsigned scnt; /* count of namelist struc items */ 01655 nmlist_goli_t *nlvar; /* ptr to NEXT Var entry */ 01656 int errn; /* error number */ 01657 int cntp; 01658 c = *lastc; 01659 scnt = count; 01660 errn = 0; 01661 nlvar = nalist; /* group object pointer */ 01662 01663 while (scnt--) { 01664 switch(nlvar->valtype) { 01665 case IO_SCALAR: 01666 { 01667 nmlist_scalar_t *nlscalar; /* nmlist scalar entry */ 01668 unsigned long elsize; 01669 unsigned int int_len; 01670 void *vaddr; 01671 ftype_t type; /* fortran data type */ 01672 int adj = 0; 01673 cntp = 1; 01674 nlscalar = nlvar->goli_addr.ptr; /* ptr to scalar */ 01675 type = nlscalar->tinfo.type; 01676 int_len = nlscalar->tinfo.int_len; 01677 /* Assertions */ 01678 assert (type >= DVTYPE_TYPELESS && 01679 type <= DVTYPE_ASCII); 01680 assert(nlscalar->tinfo.int_len > 0 ); 01681 if (type == DVTYPE_ASCII) { 01682 char *wptr; 01683 const int bytesperchar = 1; 01684 wptr = 01685 _fcdtocp(nlscalar->scal_addr.charptr) + 01686 byt; 01687 elsize = 01688 _fcdlen(nlscalar->scal_addr.charptr); 01689 elsize = elsize * bytesperchar; 01690 /* Any character substring in input record */ 01691 vaddr = wptr; 01692 } 01693 else { 01694 if (byt > 0) 01695 adj = byt/(sizeof(bcont)); 01696 vaddr = ((bcont*)nlscalar->scal_addr.ptr) + 01697 adj; 01698 elsize = int_len >> 3; 01699 } 01700 errn = _nlread(css, type, cup, vaddr, elsize, 01701 cntp, 0, &c); 01702 if (errn != 0) 01703 return(errn); 01704 *lastc = c; 01705 break; 01706 } 01707 case IO_DOPEVEC: 01708 { 01709 DopeVectorType *nldv; 01710 unsigned long elsize; 01711 unsigned long extent = 1; 01712 unsigned int int_len; 01713 void *vaddr; 01714 int nc; 01715 ftype_t type; /* fortran data type */ 01716 int adj = 0; 01717 nldv = nlvar->goli_addr.dv; /* ptr to dope vector */ 01718 /* Assertions */ 01719 assert ( nldv != NULL ); 01720 assert ( nldv->type_lens.int_len > 0 ); 01721 type = nldv->type_lens.type; 01722 int_len = nldv->type_lens.int_len; 01723 if (type == DVTYPE_ASCII) { 01724 char *wptr; 01725 const int bytesperchar = 1; 01726 wptr = _fcdtocp(nldv->base_addr.charptr) + 01727 byt; 01728 elsize = _fcdlen(nldv->base_addr.charptr); 01729 elsize = elsize * bytesperchar; 01730 vaddr = wptr; 01731 } 01732 else { 01733 if (byt > 0) 01734 adj = byt/(sizeof(bcont)); 01735 vaddr = ((bcont*)nldv->base_addr.a.ptr) + adj; 01736 elsize = int_len >> 3; 01737 } 01738 for (nc = 0; nc < nldv->n_dim; nc++) { 01739 extent *= nldv->dimension[nc].extent; 01740 } 01741 /* Assertions */ 01742 assert ( elsize > 0 && extent > 0 ); 01743 cntp = extent; 01744 errn = _nlread(css, type, cup, vaddr, elsize, 01745 cntp, 1, &c); 01746 if (errn != 0) 01747 return(errn); 01748 *lastc = c; 01749 break; 01750 } 01751 case IO_STRUC_A: 01752 { 01753 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 01754 unsigned long elsize; 01755 unsigned int int_len; 01756 unsigned int scount; 01757 nmlist_goli_t *vaddr; 01758 ftype_t type; /* fortran data type */ 01759 int bytoff; 01760 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 01761 scount = nlstruc->structlen; /* number entries */ 01762 vaddr = nlstruc->goli; /* ptr to list */ 01763 /* 01764 * No additional offset needed, pass current 01765 * offset on to next version. 01766 */ 01767 bytoff = byt; 01768 errn = 01769 _nlrdent(css, cup, vaddr, scount, &c, bytoff); 01770 if (errn != 0) 01771 return(errn); 01772 *lastc = c; 01773 break; 01774 } 01775 case IO_STRUC_S: 01776 { 01777 nmlist_struclist_t *nlstruc; /* nmlist struc entry */ 01778 unsigned long elsize; 01779 unsigned int int_len; 01780 unsigned int scount; 01781 int nc; 01782 long ic; 01783 long extnt=1; 01784 nmlist_goli_t *vaddr; 01785 DopeVectorType *nlsdv; 01786 ftype_t type; /* fortran data type */ 01787 int bytoff; 01788 nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */ 01789 scount = nlstruc->structlen; /* number entries */ 01790 vaddr = nlstruc->goli; /* ptr to list */ 01791 nlsdv = nlstruc->struc_addr.dv; /* ptr to dopevec */ 01792 /* 01793 * byt is used when the structure is an array 01794 * of structures. Each element must add an offset 01795 * to its address after the first array element. 01796 */ 01797 elsize = nlsdv->base_addr.a.el_len; 01798 for (nc = 0; nc < nlsdv->n_dim; nc++) { 01799 extnt *= nlsdv->dimension[nc].extent; 01800 } 01801 for (ic = 0; ic < extnt; ic++) { 01802 /* 01803 * create another byte offset for this 01804 * nesting of a structure of arrays. Must 01805 * change elsize from bits to bytes. 01806 */ 01807 bytoff = byt + ((elsize >> 3) * ic); 01808 errn = _nlrdent(css, cup, vaddr, scount, 01809 &c, bytoff); 01810 if (errn != 0) 01811 return(errn); 01812 } 01813 *lastc = c; 01814 break; 01815 } 01816 default: 01817 errn = FEINTUNK; 01818 } 01819 if (errn !=0) 01820 return(errn); 01821 #if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64)) 01822 nlvar = (nmlist_goli_t*)((long *)nlvar + 3 + 01823 (sizeof(_fcd))/(sizeof(long))); 01824 #else 01825 nlvar = (nmlist_goli_t*)((long *)nlvar + 2 + 01826 (sizeof(_fcd))/(sizeof(long))); 01827 #endif 01828 } 01829 return(errn); 01830 } 01831 01832 /* _nexdata - get the next data group - position at the first character 01833 * following the value or values. 01834 * On return, lval will contain the value and lcount the repeat count 01835 * Outptr will point to character immediately following value 01836 * 01837 * The return value is: -value for EOF 01838 * 0 for ok 01839 * >0 if an error 01840 * nullvlu = 1 for null value read 01841 * 2 for null value, followed by possible 01842 * variable name 01843 */ 01844 static int 01845 _nexdata( 01846 FIOSPTR css, 01847 ftype_t type, /* Type of data item */ 01848 void *ptr, /* Address of data item */ 01849 int cnt, /* Number of values to look for */ 01850 int inc, 01851 char lastc, /* First character of value, may be blank */ 01852 unit *cup, /* Input unit */ 01853 long *lval, /* Value is placed here */ 01854 int *lcount, /* Repeat count is returned here */ 01855 long elsize, 01856 int *nullvlu) /* indicate if any nulls returned */ 01857 { 01858 char c, oc; 01859 int ocnt; 01860 long *optr; 01861 int holcnt; /* Length of hollerith string */ 01862 char newc; 01863 int errn; 01864 *nullvlu = 0; 01865 c = lastc; 01866 while (ISBLANK(c)) { 01867 CMTE_SUBGTC(c); 01868 } 01869 *lcount = 1; /* set repeat count */ 01870 if (isdigit((int) c)) { 01871 /* Look for repeat count. We can have a repeat count 01872 * for any type of data, including character. 01873 */ 01874 *lcount = c - '0'; 01875 ocnt = cup->ulinecnt; /* save count and pointer, in case */ 01876 optr = cup->ulineptr; /* this isn't repeat count */ 01877 oc = c; 01878 for (;;) { 01879 /* get next character */ 01880 /* blank character if end-of-record */ 01881 SUBGTCNOEOR(c); 01882 if (isdigit((int) c)) 01883 *lcount = (*lcount * 10) + c - '0'; 01884 else 01885 break; 01886 } 01887 /* 01888 * Could have r*c, rH, rL, or rR, where r is the number just 01889 * read. No embedded blanks allowed in r*c, rH, rL, or rR. 01890 */ 01891 switch (c) { 01892 case '*': 01893 /* get next character */ 01894 /* blank character if end-of-record */ 01895 CMTE_SUBGTCNOEOR(c); 01896 if (isdigit((int) c)) { 01897 /* See if we have a repeat count followed 01898 * by hollerith, like 3*4Habcd 01899 */ 01900 holcnt = c - '0'; 01901 ocnt = cup->ulinecnt; 01902 optr = cup->ulineptr; 01903 oc = c; 01904 for (;;) { 01905 /* blank character if end-of-record */ 01906 SUBGTCNOEOR(c); 01907 if (isdigit((int) c)) 01908 holcnt = (holcnt * 10) + 01909 c - '0'; 01910 else 01911 break; 01912 } 01913 switch (c) { 01914 case 'H': 01915 case 'h': 01916 case 'R': 01917 case 'r': 01918 case 'L': 01919 case 'l': 01920 return(_get_holl(css, cup, c, holcnt, 01921 type, lval, elsize)); 01922 default: 01923 /* backup restore */ 01924 cup->ulineptr = optr; 01925 /* cnt and ptr */ 01926 cup->ulinecnt = ocnt; 01927 c = oc; 01928 ocnt = 1; 01929 break; 01930 } /* switch */ 01931 } 01932 break; /* Ordinary repeat count */ 01933 case 'H': 01934 case 'h': 01935 case 'R': 01936 case 'r': 01937 case 'L': 01938 case 'l': 01939 /* Assume it is a Hollerith string, like 3Habc */ 01940 holcnt = *lcount; 01941 *lcount = 1; /* No repeats */ 01942 return(_get_holl(css, cup, c, holcnt, type, 01943 lval, elsize)); 01944 default: 01945 /* No repeat count, backup restore, cnt & ptr */ 01946 cup->ulineptr = optr; 01947 cup->ulinecnt = ocnt; 01948 c = oc; 01949 ocnt = 1; 01950 *lcount = 1; 01951 break; 01952 } /* switch */ 01953 } 01954 /* END of isdigit() 01955 * Looking for a value. When we get here we are at a nonblank 01956 * character, unless we had the form r*, in which case it may 01957 * be followed by a blank (NULL). 01958 */ 01959 if (c == ',') { 01960 cup->ulineptr--; /* reset cnt and ptr so */ 01961 cup->ulinecnt++; /* we can read separator again */ 01962 *nullvlu = 1; 01963 return(0); /* return null value */ 01964 } 01965 else if (ISBLANK(c)) { 01966 *nullvlu = 1; 01967 return(0); /* return null value */ 01968 } 01969 else { 01970 if (c == '!') { 01971 /* use this path with input like: a = 5,!comment */ 01972 cup->ulineptr--; /* reset cnt and ptr so */ 01973 cup->ulinecnt++; /* we can read separator again */ 01974 *nullvlu = 1; 01975 return(0); /* return null value */ 01976 } else 01977 if (c == '/' || c == '&' || c == '$') { 01978 /* treated terminating slash or ampersand 01979 * the same for f90 to allow simpler 01980 * non-f90 compatibility. 01981 */ 01982 cup->ulineptr--; /* reset cnt and ptr so */ 01983 cup->ulinecnt++; /* read delimiter again */ 01984 *nullvlu = 2; 01985 return(0); /* Return null value */ 01986 } 01987 } 01988 /* 01989 * It is important that we handle the special cases of types logical 01990 * and character first, because the format of their data is treated 01991 * differently. 01992 */ 01993 if (type == DVTYPE_LOGICAL) { 01994 bcont *slval; 01995 slval = (bcont *)lval; 01996 01997 /* Looking for a logical value. Logical values must be of 01998 * the form: optional decimal point, followed by a 'T' for 01999 * true or an 'F' for false, optionally followed by one 02000 * or more additional characters. Those additional 02001 * characters cannot include '=', ',', ':', ';', '(', '$' 02002 * or '&'. 02003 */ 02004 if (c == '.') { 02005 /* blank character if end-of-record */ 02006 SUBGTCNOEOR(c); 02007 /* .T or .t assumed to be a logical value */ 02008 if ((c == 'T') || (c == 't')) { 02009 switch (elsize) { 02010 #ifdef _F_INT4 02011 case 4: 02012 *(_f_log4 *)slval = _btol(1); 02013 break; 02014 #if defined(_F_INT2) && (defined(__mips) || defined(__sv2)) 02015 case 2: 02016 *(_f_log2 *)slval = _btol(1); 02017 break; 02018 case 1: 02019 *(_f_log1 *)slval = _btol(1); 02020 break; 02021 #endif /* _F_INT2 and (mips or sv2) */ 02022 #endif /* _F_INT4 */ 02023 case 8: 02024 *(_f_log8 *)slval = _btol(1); 02025 break; 02026 default: 02027 return(FEKNTSUP); /* kind not supported */ 02028 } 02029 02030 /* F and .f are assumed to be a logical value */ 02031 } else if ((c == 'F') || (c == 'f')) { 02032 switch (elsize) { 02033 #ifdef _F_INT4 02034 case 4: 02035 *(_f_log4 *)slval = _btol(0); 02036 break; 02037 #if defined(_F_INT2) && (defined(__mips) || defined(__sv2)) 02038 case 2: 02039 *(_f_log2 *)slval = _btol(0); 02040 break; 02041 case 1: 02042 *(_f_log1 *)slval = _btol(0); 02043 break; 02044 #endif /* _F_INT2 and (mips or sv2) */ 02045 #endif /* _F_INT4 */ 02046 case 8: 02047 *(_f_log8 *)slval = _btol(0); 02048 break; 02049 default: 02050 return(FEKNTSUP); /* kind not supported */ 02051 } 02052 } else { 02053 errn = FENLIVLG; /* Invalid logical */ 02054 return(errn); 02055 } 02056 } 02057 else { 02058 /* If the string does not start with a '.', it could 02059 * be a logical value or a variable name. Try to 02060 * determine which by seeing if it is followed by a 02061 * replacement character or '('. Save count and 02062 * pointer in case this isn't a value. 02063 */ 02064 ocnt = cup->ulinecnt; 02065 optr = cup->ulineptr; 02066 /* do not go beyond the end of the buffer */ 02067 if (ocnt > 0) { 02068 newc = *optr++; 02069 ocnt--; 02070 while (!(ISBLANK(newc))) { 02071 /* check for terminating or separator char */ 02072 if (newc == ',' || newc == '/' || 02073 newc == '&' || newc == '$') 02074 break; 02075 if ((newc == '=') || (newc == '(') || 02076 (newc == '%')) { 02077 /* Reset, this MAY be the first 02078 * letter of a variable name 02079 */ 02080 cup->ulineptr--; 02081 cup->ulinecnt++; 02082 *nullvlu = 2; 02083 return(0); /* Null value */ 02084 } 02085 if (ocnt <= 0) 02086 break; 02087 newc = *optr++; 02088 ocnt--; 02089 } 02090 while ((ISBLANK(newc)) && ocnt-- > 0) 02091 newc = *optr++; 02092 if (newc == '=') { 02093 /* 02094 * Reset, because this MAY have been 02095 * the first letter of a variable name 02096 */ 02097 cup->ulineptr--; 02098 cup->ulinecnt++; 02099 *nullvlu = 2; 02100 return(0); /* Null value */ 02101 } 02102 } 02103 if ((c == 'T') || (c == 't')) { 02104 switch (elsize) { 02105 #ifdef _F_REAL4 02106 case 4: 02107 *(_f_log4 *)slval = _btol(1); 02108 break; 02109 #if defined(_F_INT2) && (defined(__mips) || defined(__sv2)) 02110 case 2: 02111 *(_f_log2 *)slval = _btol(1); 02112 break; 02113 case 1: 02114 *(_f_log1 *)slval = _btol(1); 02115 break; 02116 #endif /* _F_INT2 and (mips or sv2) */ 02117 #endif 02118 case 8: 02119 *(_f_log8 *)slval = _btol(1); 02120 break; 02121 default: 02122 return(FEKNTSUP); /* kind not supported */ 02123 } 02124 } 02125 else if ((c == 'F') || (c == 'f')) { 02126 switch (elsize) { 02127 #ifdef _F_REAL4 02128 case 4: 02129 *(_f_log4 *)slval = _btol(0); 02130 break; 02131 #if defined(_F_INT2) && (defined(__mips) || defined(__sv2)) 02132 case 2: 02133 *(_f_log2 *)slval = _btol(0); 02134 break; 02135 case 1: 02136 *(_f_log1 *)slval = _btol(0); 02137 break; 02138 #endif /* _F_INT2 and (mips or sv2) */ 02139 #endif 02140 case 8: 02141 *(_f_log8 *)slval = _btol(0); 02142 break; 02143 default: 02144 return(FEKNTSUP); /* kind not supported */ 02145 } 02146 } 02147 else if (ISBLANK(c) || c == ',') { 02148 *nullvlu = 1; 02149 return(0); /* Indicate null value */ 02150 } 02151 else { 02152 errn = FENLIVLG; /* Invalid logical */ 02153 return(errn); 02154 } 02155 } 02156 /* We assume we're reading a logical value. 02157 * Skip to the end of this value. 02158 */ 02159 while ( !(ISBLANK(c))) { 02160 CMTE_SUBGTCNOEOR(c); 02161 /* check for separator or terminating character */ 02162 if (c == '/' || c == ',' || c == '&' || c == '$') { 02163 /* Reset cnt and ptr for conversion routine */ 02164 cup->ulineptr--; 02165 cup->ulinecnt++; 02166 return(0); /* return logical value */ 02167 } 02168 } 02169 return(0); /* return logical value */ 02170 } /* End of type logical */ 02171 /* if type character, read character data */ 02172 if (type == DVTYPE_ASCII) 02173 return (_g_charstr(css, cup, ptr, cnt, c, *lcount, 02174 elsize, nullvlu)); 02175 /* Get value for variable that is not type LOGICAL or CHARACTER */ 02176 if (isdigit((int) c) || c == '+' || c == '-' || c == '.') { 02177 if (type == DVTYPE_COMPLEX) { 02178 errn = FENLIVCX; 02179 return(errn); 02180 } 02181 return(_g_number(type, cup, lval, elsize)); 02182 } 02183 /* When we get here we are looking for a VALUE. We are at a 02184 * nonblank character which is not a digit, +, or -, separator, 02185 * comment or delimiter. 02186 * A left parenthesis indicates complex data 02187 * An apostrophe or quote indicates hollerith data 02188 * A letter o indicates octal data 02189 * A letter z indicates hexadecimal data 02190 */ 02191 if (c == '(') { 02192 return(_g_complx(css, cup, type, lval, elsize)); 02193 } 02194 else if ((c == '\'') || (c == '"')) { 02195 return(_get_quoholl(css, cup, c, type, lval, elsize)); 02196 } 02197 else if (c == 'O' || c == 'o') { 02198 return(_gocthex(css, cup, type, lval, OCTAL, elsize, nullvlu)); 02199 } 02200 else if (c == 'Z' || c == 'z') { 02201 return(_gocthex(css, cup, type, lval, HEX, elsize, nullvlu)); 02202 } 02203 else { 02204 /* No valid value. 02205 * Reset cup->ulineptr, because this MAY have been the first 02206 * character of a variable name. For example, if we have: 02207 * integer var1(3),var2, with input: var1=2, var2 = 5 02208 * then when we try to read the value for var1(2), we will 02209 * see 'var2' 02210 */ 02211 cup->ulineptr--; 02212 cup->ulinecnt++; 02213 *nullvlu = 2; 02214 return(0); /* Return null value */ 02215 } 02216 } 02217 02218 /* _g_complx - get the value for a complex number. 02219 * On entry: 02220 * positioned at '(' for a complex number. 02221 * Returns: 0 if OK, 02222 * -value if EOF 02223 * > 0 with valid error number if an error 02224 */ 02225 02226 static int 02227 _g_complx( 02228 FIOSPTR css, unit*cup, ftype_t type, long *lval, long elsize) 02229 { 02230 char c; 02231 long mode, stat; 02232 long zero = 0; 02233 long field_width; 02234 long *field_begin; 02235 long *field_end; 02236 int i, errn; 02237 int nc; 02238 ic_func *ngcf; 02239 int inc; 02240 int ptrfw; 02241 bcont *slval; 02242 /* 02243 * IN reading the complex number, assume 02244 * intervening EOR is OK 02245 */ 02246 if (type != DVTYPE_COMPLEX) { 02247 errn = FENLIVCX; /* not complex type */ 02248 return(errn); 02249 } 02250 /* 02251 * Call the function from the ncf_tab90 table. 02252 */ 02253 02254 ngcf = ncf_tab90[type]; 02255 mode = 0; 02256 02257 switch (elsize) { 02258 #ifdef _F_REAL4 02259 case 8: 02260 mode = MODEHP; 02261 break; 02262 #endif 02263 case 16: 02264 break; 02265 case 32: 02266 mode = MODEDP; 02267 break; 02268 default: 02269 return(FEKNTSUP); /* kind not supported */ 02270 } 02271 inc = (elsize / 2) / (sizeof(bcont)); 02272 slval = (bcont*)lval; 02273 02274 /* loop and get both real and imaginary */ 02275 for (i = 0; i < 2; i++) { 02276 do { 02277 SUBGTC(c); /* skip the '(' */ 02278 } while (ISBLANK(c)); /* skip blanks */ 02279 cup->ulinecnt++; /* backup 1 character */ 02280 cup->ulineptr--; /* backup 1 character */ 02281 field_begin = cup->ulineptr; 02282 field_end = cup->ulineptr; 02283 field_width = cup->ulinecnt; 02284 nc = 0; 02285 02286 while (nc < cup->ulinecnt && !(ISSEP(*field_end) || 02287 *field_end == ')' || *field_end == '&' || 02288 *field_end == '$' )) { 02289 field_end++; 02290 nc++; 02291 } 02292 /* pass field_end + 1 */ 02293 field_end++; 02294 field_width = nc; 02295 /* convert both the real and imaginary parts */ 02296 errn = ngcf(field_begin, &field_width, &field_end, 02297 &mode, slval + (i * inc), &stat, &zero, &zero); 02298 02299 /* If the scan failed, the input data might be 02300 * Hollerith or hex or octal. Allow _s_scan_extensions 02301 * _s_scan_extensions to rescan the input and 02302 * recompute the field width. 02303 */ 02304 if (errn < 0) { 02305 errn = _nicverr(stat); 02306 } else 02307 errn = 0; 02308 02309 /* if (errn == EX_ILLCHAR) */ 02310 if (errn == FENICVIC) { 02311 int errn2; 02312 errn2 = _s_scan_extensions(slval + (i * inc), 02313 type, elsize, field_begin, 02314 field_width, &ptrfw, mode); 02315 02316 cup->ulineptr += ptrfw; 02317 cup->ulinecnt -= ptrfw; 02318 if (errn2 <= 0) 02319 errn = 0; 02320 else 02321 /* errors FELDUNKI and FELDSTRL 02322 * are currently returned. 02323 */ 02324 return(FENLIVCX); 02325 } else { 02326 cup->ulineptr = field_begin + field_width; 02327 cup->ulinecnt -= cup->ulineptr - field_begin; 02328 if (errn != 0) 02329 return(errn); 02330 } 02331 do { 02332 SUBGTC(c); 02333 } while (ISBLANK(c)); 02334 if ((c != ',') && (i == 0)) 02335 return(FENLIVCX); /* err in cmplx no. form */ 02336 } 02337 if ( c != ')') 02338 return(FENLIVCX); /* err in complex number format */ 02339 return(0); 02340 } 02341 02342 /* 02343 * _g_number - Read a number. 02344 * Returns: 0 if ok 02345 * -value if EOF 02346 * > 0 if error 02347 */ 02348 02349 static int 02350 _g_number( 02351 ftype_t type, 02352 unit *cup, 02353 long *lval, 02354 long elsize) 02355 { 02356 long mode, stat; 02357 long zero = 0; 02358 long field_width; 02359 long *field_begin; 02360 long *field_end; 02361 int ss = 0; 02362 int errn = 0; 02363 int nc; 02364 ic_func *ngcf; 02365 int ptrfw; 02366 bcont *slval; 02367 02368 mode = 0; 02369 02370 switch (type) { 02371 case DVTYPE_REAL: 02372 switch (elsize) { 02373 #ifdef _F_REAL4 02374 case 4: 02375 mode = MODEHP; 02376 break; 02377 #endif 02378 case 8: 02379 break; 02380 case 16: 02381 mode = MODEDP; 02382 break; 02383 default: 02384 return(FEKNTSUP); 02385 } 02386 break; 02387 case DVTYPE_INTEGER: 02388 switch (elsize) { 02389 #ifdef _F_INT4 02390 case 4: 02391 mode = MODEHP; 02392 break; 02393 #if defined(_F_INT2) && (defined(__mips) || defined(__sv2)) 02394 case 2: 02395 mode = MODEWP; 02396 break; 02397 case 1: 02398 mode = MODEBP; 02399 break; 02400 #endif /* _F_INT2 and (mips or sv2) */ 02401 #endif /* _F_INT4 */ 02402 case 8: 02403 break; 02404 default: 02405 return(FEKNTSUP); 02406 } 02407 break; 02408 } 02409 /* 02410 * Call the function from the ncf_tab90 table. 02411 */ 02412 ngcf = ncf_tab90[type]; 02413 cup->ulinecnt++; /* backup 1 character */ 02414 cup->ulineptr--; /* backup 1 character */ 02415 field_begin = cup->ulineptr; 02416 field_end = cup->ulineptr; 02417 field_width = cup->ulinecnt; 02418 slval = (bcont*)lval; 02419 nc = 0; 02420 while (nc < cup->ulinecnt && !(ISSEP(*field_end) || 02421 *field_end == '&' || *field_end == '$')) { 02422 field_end++; 02423 nc++; 02424 } 02425 /* pass field_end + 1 */ 02426 field_end++; 02427 field_width = nc; 02428 errn = ngcf(field_begin, &field_width, &field_end, 02429 &mode, slval, &stat, &zero, &zero); 02430 02431 /* If the scan failed, the input data might be 02432 * Hollerith or hex or octal. Allow _s_scan_extensions 02433 * _s_scan_extensions to rescan the input and 02434 * recompute the field width. 02435 */ 02436 if (errn < 0) { 02437 ss = _nicverr(stat); 02438 if (ss == 0) 02439 errn = 0; 02440 } else 02441 errn = 0; 02442 02443 /* if (errn == EX_ILLCHAR) */ 02444 if (ss == FENICVIC) { 02445 int errn2; 02446 errn2 = _s_scan_extensions(slval, 02447 type, elsize, field_begin, 02448 field_width, &ptrfw, mode); 02449 02450 cup->ulineptr = field_begin + field_width; 02451 cup->ulinecnt -= cup->ulineptr - field_begin; 02452 if (errn2 >= 0) 02453 errn = 0; 02454 else 02455 /* errors FELDUNKI and FELDSTRL 02456 * are currently returned. 02457 */ 02458 errn = FENLUNKI; 02459 return(errn); 02460 } else { 02461 cup->ulineptr = field_begin + field_width; 02462 cup->ulinecnt -= cup->ulineptr - field_begin; 02463 } 02464 return(errn); 02465 } 02466 02467 /* _g_charstr - read a character string 02468 * 02469 * Input: cup_ulineptr will point one past the first character of the string. 02470 * "c" will contain the first character of the string. 02471 * Returns: 0 if ok, 02472 * -value if EOF 02473 * > 0 if error 02474 */ 02475 02476 static int 02477 _g_charstr( 02478 FIOSPTR css, 02479 unit *cup, 02480 void *p, /* Address of variable being read */ 02481 int cnt, /* Number of strings we expect to read */ 02482 char c, /* First character of string. */ 02483 int lcount, /* Repeat count */ 02484 long elsize, 02485 int *nullvlu) 02486 { 02487 int eos; /* eos == -1 if end or beginning of string */ 02488 int i, ch; 02489 unsigned int len77; 02490 char *cp; 02491 char enddelim; 02492 char c1; 02493 int repcount; 02494 char *cpold; 02495 int errn = 0; 02496 long *optr; 02497 int ocnt; 02498 void *fchp; 02499 *nullvlu = 0; 02500 /* 02501 * Character data may be enclosed in apostrophes or quotation marks. 02502 * Each apostrophe within a character constant delimited by 02503 * apostrophes must be represented by 2 consecutive apostrophes 02504 * without an intervening blank or end of record. The same holds 02505 * true for quotation marks. Character constants may be continued 02506 * from the end of one record to the beginning of the next record. 02507 * The end of the record does not cause a blank or any other 02508 * character to become part of the constant. 02509 * Blank characters, separator characters, comment characters, and 02510 * delimiter characters may appear in character constants. 02511 * 02512 * For cf77 only (F90 does not allow undelimited character on input): 02513 * If the character constant has the following properties: 02514 * 1. It does not contain blank characters, 02515 * separator characters, comment characters, left parenthesis 02516 * or delimiter characters. 02517 * 2. It does not cross a record boundary, 02518 * 3. the first nonblank character is not a quotation mark or 02519 * apostrophe, 02520 * 4. the leading characters are not numeric followed by asterisk, 02521 * 5. the leading characters are not numeric followed by R, H, or L 02522 * then the enclosing apostrophes or quotation marks are not required 02523 * and apostrophes or quotation marks within the character constant 02524 * are not to be doubled. 02525 * 02526 * Let len be the length of the list item, and let w be the length 02527 * of the character constant. If len is less than or equal to w, 02528 * the leftmost len characters of the constant are transmitted to the 02529 * variable. If len is greater than w, the constant is transmitted to 02530 * the leftmost w characters of the variable and the remaining len-w 02531 * characters of the list item are filled with blanks. 02532 * 02533 * f90 allows zero-length character and it uses one input data item 02534 * from the input record. It does not store the value to the 02535 * the zero-sized character entity. cf77 does not allow this feature. 02536 */ 02537 eos = 0; 02538 fchp = p; 02539 len77 = elsize; /* Get character length */ 02540 /* f90 allows zero-length character entities */ 02541 cp = fchp; 02542 repcount = MIN(lcount,cnt); 02543 /* 02544 * If the first character is a quote or apostrophe, we expect 02545 * that character to delimit the end of the string. 02546 */ 02547 if ((c == '\'') || (c == '"')) { 02548 enddelim = c; 02549 /* find characters in string */ 02550 for (i = 0; i < len77 && eos == 0; i++) { 02551 GETSTRD(); 02552 if (eos == 0) 02553 *cp++ = ch; 02554 } 02555 if (eos == -1) 02556 i--; 02557 i = len77 - i; /* If declared len > read len */ 02558 if (i > 0) 02559 (void) memset(cp, BLANK, i); /* blank fill */ 02560 cp = cp + i; 02561 while (eos != -1) { 02562 /* 02563 * We didn't hit the end of the string yet. 02564 * Search for it. 02565 */ 02566 GETSTRD(); 02567 } 02568 while (--repcount) { 02569 /* We have a repeat count. 02570 * cp will point to the next element. 02571 * Copy len77 characters to the next element. 02572 */ 02573 cpold = fchp; 02574 (void) memcpy(cp, cpold, len77); 02575 cp = cp + len77; /* Next element */ 02576 } 02577 } else { 02578 /* 02579 * We have a character string that's not surrounded 02580 * by quotes (or apostrophes). Read until we see a 02581 * blank, separator, comment, or EOR (which looks 02582 * like a blank to us). Store as many of them as 02583 * we have room for. We cannot have a repeat count 02584 * unless we're surrounded by quotes or apostrophes. 02585 */ 02586 if (lcount > 1) { 02587 errn = FENLNOVL; /* invalid char data */ 02588 return(errn); 02589 } 02590 /* 02591 * Determine if this is a value or a variable name. 02592 * Save count and pointer in case this isn't a value. 02593 */ 02594 ocnt = cup->ulinecnt; 02595 optr = cup->ulineptr; 02596 c1 = *optr++; 02597 ocnt--; 02598 02599 while (!(ISBLANK(c1))) { 02600 /* check for separator or terminating character */ 02601 if (c1 == ',' || c1 == '/' || c1 == '&' || c == '$') 02602 break; /* Assume value */ 02603 if (c1 == '=' || c1 == '(' || c1 == '%') { 02604 /* Reset, this MAY be the first 02605 * letter of a variable name. 02606 */ 02607 cup->ulineptr--; 02608 cup->ulinecnt++; 02609 *nullvlu = 2; 02610 return(0); /* Null value */ 02611 } 02612 c1 = *optr++; 02613 ocnt--; 02614 } 02615 while ((ISBLANK(c1)) && ocnt-- > 0) 02616 c1 = *optr++; 02617 if (c1 == '=' || c1 == '(' || c1 == '%') { 02618 /* 02619 * Reset, this MAY be the first letter 02620 * of a variable name. 02621 */ 02622 cup->ulineptr--; 02623 cup->ulinecnt++; 02624 *nullvlu = 2; 02625 return(0); /* Null value */ 02626 } 02627 /* f90 does not allow undelimited character */ 02628 errn = FENLUNKI; /* undelimited char */ 02629 return(errn); 02630 } 02631 return(errn); 02632 } 02633 02634 /* _get_holl - Read a hollerith string. 02635 * 02636 * Returns: 0 if a value was found, 02637 * -value if EOF 02638 * > 0 if an error occurred 02639 */ 02640 02641 static int 02642 _get_holl( 02643 FIOSPTR css, 02644 unit *cup, 02645 char holltype, 02646 int count, /* Number of characters in string */ 02647 ftype_t type, /* Type of data item */ 02648 long *lval, 02649 long elsize) 02650 { 02651 int i; 02652 char *holbufptr; 02653 char c; 02654 int errn = 0; 02655 int fill; 02656 /* 02657 * Read 'count' characters from the current word, packing them 02658 * left justified into lval[0]. 02659 * 02660 * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data. 02661 * Hollerith input is supported for compatibility with 02662 * old versions of namelist. 02663 * 02664 * Because we don't allow CHARACTER data, we can make the 02665 * simplifying assumption that we start on a word boundary. 02666 * Also, we are going to assume that whatever we read in will need 02667 * to fit in one word. Repeat counts are allowed. If it becomes 02668 * necessary to allow hollerith strings of > 8 characters, some 02669 * thought will need to be given as to how to handle repeat counts. 02670 */ 02671 if (type == DVTYPE_COMPLEX || type == DVTYPE_ASCII || 02672 ((type == DVTYPE_REAL) && elsize == sizeof(_f_real16))) { 02673 errn = FENLUNKI; 02674 return(errn); 02675 } 02676 if (count > elsize) { 02677 errn = FENLIOER; 02678 return(errn); 02679 } 02680 fill = BLANK; 02681 holbufptr = (char *)lval; 02682 if (holltype == 'R' || holltype == 'r') { 02683 /* right justified */ 02684 fill = NULLC; 02685 holbufptr = holbufptr + (elsize - count); 02686 } 02687 else 02688 if (holltype == 'L' || holltype == 'l') 02689 fill = NULLC; 02690 /* Last character in buffer is the EOR character, 02691 * that's why we check for cup->ulinecnt > 1 02692 */ 02693 for (i = 0; i < count && (cup->ulinecnt > 1) ; i++) { 02694 SUBGTC(c); /* comment characters are not special 02695 * within hollerith string */ 02696 *holbufptr++ = c; 02697 } 02698 if (i == count) { 02699 /* Do we need to fill the last word? */ 02700 if (holltype == 'R' || holltype == 'r') /* right justified? */ 02701 holbufptr = (char *)lval; 02702 (void) memset(holbufptr, fill, elsize - count); 02703 } 02704 else { 02705 /* 02706 * We hit EOR before we read enough characters _or_ we had 02707 * too many characters. 02708 */ 02709 errn = FENLIOER; 02710 return(errn); 02711 } 02712 return(errn); 02713 } 02714 02715 /* _get_quoholl 02716 * Get a hollerith string that is surrounded by quotes or apostrophes 02717 * Legal syntax is '----'L, '----'R, or '----'H 02718 * 02719 * Returns: 0 if a value was found, 02720 * -value if EOF 02721 * > 0 if an error occurred 02722 */ 02723 02724 static int 02725 _get_quoholl( 02726 FIOSPTR css, 02727 unit *cup, 02728 char cdelim, /* Quote or apostrophe (to end hollerith) */ 02729 ftype_t type, /* Type of data */ 02730 long *lval, /* Value is placed here */ 02731 long elsize) /* size */ 02732 { 02733 int numchar; /* character counter */ 02734 int j; 02735 int fill; /* Fill character is either ' ' or '\0' */ 02736 long holbuf; /* Data is stored here until we know whether 02737 it is right or left justified. */ 02738 char *holbufptr; /* pointer into holbuf */ 02739 char c; /* Character read */ 02740 char *lvalcharptr; /* Pointer to value */ 02741 int errn = 0; 02742 /* 02743 * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data. 02744 * Hollerith input is supported for compatibility with 02745 * old versions of namelist. 02746 * 02747 * Because we don't allow CHARACTER data, we can make the 02748 * simplifying assumption that we start on a word boundary. 02749 * Also, we are going to assume that whatever we read in will need 02750 * to fit in one word. Repeat counts are allowed. If it becomes 02751 * necessary to allow hollerith strings of > 8 characters, some 02752 * thought will need to be given as to how to handle repeat counts. 02753 */ 02754 if (type == DVTYPE_COMPLEX || type == DVTYPE_ASCII || 02755 (type == DVTYPE_REAL && elsize == sizeof(_f_real16))) { 02756 errn = FENLUNKI; 02757 return(errn); 02758 } 02759 lvalcharptr = (char *)lval; 02760 holbufptr = (char *) &holbuf; 02761 /* Do not allow quoted strings to be continued on another record. */ 02762 numchar = 0; 02763 for (;;) { 02764 SUBGTC(c); 02765 if (c == cdelim) { 02766 /* Allow Comment characters within quoted string */ 02767 SUBGTC(c); 02768 if (c != cdelim) 02769 break; /* That was the end of the quoted 02770 * string. Otherwise, we saw two 02771 * quotes in a row, which means 02772 * we store one. 02773 */ 02774 } 02775 if (++numchar > elsize) { 02776 errn = FENLIOER; 02777 return(errn); 02778 } 02779 *holbufptr++ = c; /* Save the character */ 02780 /* 02781 * Last character in input buffer is not EOR character, 02782 * that's why we check for cup->ulinecnt <= 0 02783 */ 02784 if (cup->ulinecnt <= 0) { 02785 errn = FENLIOER; 02786 return(errn); 02787 } 02788 } /* On exit from this loop, numchar = number of chars. stored */ 02789 if (c == 'L' || c == 'l') 02790 fill = NULLC; 02791 else if (c == 'R' || c == 'r') { 02792 /* Right justify and store the value just read */ 02793 holbufptr = holbufptr - 1; /* Last character */ 02794 lvalcharptr = lvalcharptr + (elsize - 1); 02795 j = elsize - numchar; 02796 while (numchar-- > 0) 02797 *lvalcharptr-- = *holbufptr--; 02798 02799 /* Fill word with 0's if necessary */ 02800 while (j-- > 0) 02801 *lvalcharptr-- = '\0'; 02802 return(0); 02803 } 02804 else { 02805 /* H format */ 02806 fill = BLANK; 02807 if (c != 'H' && c != 'h') { 02808 /* Reset pointers since the character does */ 02809 /* not belong to this value */ 02810 cup->ulineptr--; 02811 cup->ulinecnt++; 02812 } 02813 } 02814 /* Do we need to fill the last word? */ 02815 (void) memset(holbufptr, fill, elsize - numchar); 02816 *lval = holbuf; 02817 return(errn); 02818 } 02819 02820 /* _gocthex - provides octal or hex editing for compatibility with old 02821 * versions of namelist. 02822 * Legal formats: O'123 or O'123'. Octal number may not contain blanks, 02823 * and this is a difference with the old version of namelist. 02824 * Legal formats: Z'1a3 or Z'1a3'. 02825 * 02826 * On input: 02827 * cup_ulineptr should point to the character immediately following the O 02828 * Returns: 0 if a value was found, 02829 * -value if EOF 02830 * >0 if an error occurred 02831 * nullvlu = 1 if a null value was found 02832 * 2 if a null value was found, and it is not followed 02833 * by another value 02834 */ 02835 02836 static int 02837 _gocthex( 02838 FIOSPTR css, 02839 unit *cup, 02840 ftype_t type, 02841 long *lval, 02842 int base, 02843 long elsize, 02844 int *nullvlu) 02845 { 02846 char c; 02847 char strbuf[2]; 02848 int errn = 0; 02849 int octshift = OCTSHFT; 02850 int hexshift = HEXSHFT; 02851 /* check size in bytes of incoming variable. */ 02852 #if defined(_F_REAL4) && defined(_F_INT4) 02853 if (elsize <= 4) { 02854 octshift = OCTSHFT4; 02855 hexshift = HEXSHFT4; 02856 } 02857 #endif 02858 *nullvlu = 0; 02859 if (*cup->ulineptr != '\'') { 02860 /* Can't be a value, might be a variable name */ 02861 cup->ulineptr--; 02862 cup->ulinecnt++; 02863 *nullvlu = 2; 02864 return(0); /* NULL value */ 02865 } 02866 /* This type of format won't work for complex or double precision */ 02867 if (type == DVTYPE_COMPLEX || (type == DVTYPE_REAL && 02868 elsize == sizeof(_f_real16))) { 02869 errn = FENLUNKI; /* type mismatch */ 02870 return(errn); 02871 } 02872 /* if not enough characters in record for octal/hex constant, err */ 02873 if (cup->ulinecnt <= 1) { 02874 errn = FENLIOER; 02875 return(errn); 02876 } 02877 SUBGTC(c); /* Skip the apostrophe */ 02878 SUBGTC(c); /* and get the next character */ 02879 *lval = 0; 02880 strbuf[1] = '\0'; 02881 while (!(ISBLANK(c)) && c != '\'') { 02882 if (base == OCTAL) { 02883 if ((!isdigit((int) c)) || (c == '9') || 02884 (*lval >> octshift)) { 02885 errn = FENICVIC; /* NICV type err */ 02886 return(errn); 02887 } 02888 *lval = (*lval * 8) + c - '0'; 02889 } 02890 else { /* Check for hex digit or overflow */ 02891 if ((!isxdigit(c)) || (*lval >> hexshift)) { 02892 errn = FENICVIC; /* NICV type err */ 02893 return(errn); 02894 } 02895 strbuf[0] = c; 02896 *lval = (*lval * 16) + 02897 (int) strtol(strbuf, (char **)NULL, 16); 02898 } 02899 /* check for comment after value */ 02900 CMTE_SUBGTC(c); 02901 if (c == ',') { 02902 cup->ulineptr--; 02903 cup->ulinecnt++; /* to read separator after */ 02904 break; /* return from this routine */ 02905 } 02906 } 02907 return(errn); /* indicate value */ 02908 } 02909 02910 /* 02911 * _nl_stride_dv 02912 * Call a specified function to transfer a data area defined 02913 * by a dopevector. This corresponds to an array section. 02914 * Arguments 02915 * dv - dope vector which describes the array section. 02916 * sectn - Dimension information in input record. 02917 * Return Value 02918 * 0 normal return 02919 * FERDPEOF if end of file condition 02920 * >0 if error condition 02921 */ 02922 02923 static int 02924 _nl_stride_dv( 02925 FIOSPTR css, 02926 unit *cup, 02927 DopeVectorType *dv, 02928 struct DvDimen *sectn, 02929 char *lastch, 02930 long strbegend[3]) 02931 { 02932 int nd; 02933 int i; 02934 long extent; /* extent of first dimension */ 02935 long inc; /* stride in items */ 02936 long ret = 0; 02937 ftype_t f90type; /* F90 data type code */ 02938 long elsize; /* byte size of each element */ 02939 long element_stride; /* 1 iff elsize divides stride*/ 02940 register long id1, id2, id3, id4, id5, id6, id7; 02941 struct DvDimen *dvdimen; 02942 long badjust; /* offset for collapsed dims */ 02943 bcont *addr; /* for numeric data */ 02944 char *baddr; /* for byte-oriented data */ 02945 void *addr2, *addr3, *addr4; 02946 void *addr5, *addr6; 02947 struct DvDimen dimen[MAXDIM]; 02948 long begt = strbegend[1]; 02949 long endt = strbegend[2]; 02950 02951 /* Assertions */ 02952 assert ( dv != NULL ); 02953 assert ( dv->type_lens.int_len > 0 ); 02954 02955 if (dv->p_or_a && (dv->assoc == 0)) 02956 return(FEPTRNAS); /* pointer not associated */ 02957 02958 f90type = dv->type_lens.type; 02959 nd = dv->n_dim; 02960 badjust = 0; 02961 02962 /* 02963 * Make a local copy of dimension information so we may optimize it. 02964 */ 02965 for (i = 0; i < nd; i++) 02966 dimen[i] = dv->dimension[i]; 02967 02968 /* 02969 * Fold any indexes into the new dimension structure. The 02970 * result is that we can ignore the low_bound field in the 02971 * nested loops. 02972 * 02973 * We also collapse (remove) indexed dimensions and 02974 * unindexed dimensions with extents of one. 02975 */ 02976 dvdimen = dv->dimension; 02977 for (i = 0; i < nd; i++) { 02978 if (sectn == NULL) { 02979 02980 /* bail out here if any extent is 0 */ 02981 if (dvdimen[i].extent == 0) 02982 return(0); 02983 } 02984 else { 02985 /* collapse this indexed dimension */ 02986 badjust += (sectn[i].low_bound - 02987 dvdimen[i].low_bound) * 02988 dvdimen[i].stride_mult; 02989 if (dvdimen[i].extent != sectn[i].extent) 02990 dimen[i].extent = sectn[i].extent; 02991 if (dvdimen[i].stride_mult != sectn[i].stride_mult) 02992 dimen[i].stride_mult = sectn[i].stride_mult; 02993 } 02994 } 02995 02996 if (f90type == DVTYPE_ASCII) { 02997 02998 elsize = _fcdlen(dv->base_addr.charptr); /* in bytes */ 02999 extent = dimen[0].extent; 03000 inc = 0; 03001 element_stride = 1; 03002 03003 if (extent > 1) { 03004 register int stm = dimen[0].stride_mult; 03005 03006 inc = stm / elsize; 03007 if (inc * elsize != stm) 03008 element_stride = 0; /* it's a section of substrings */ 03009 } 03010 03011 baddr = _fcdtocp(dv->base_addr.charptr) + 03012 badjust * (dv->type_lens.int_len >> 3); 03013 03014 switch(nd) { 03015 case 7: 03016 for (id7 = 0; id7 < dimen[6].extent; id7++) { 03017 addr6 = baddr; 03018 case 6: 03019 for (id6 = 0; id6 < dimen[5].extent; id6++) { 03020 addr5 = baddr; 03021 case 5: 03022 for (id5 = 0; id5 < dimen[4].extent; id5++) { 03023 addr4 = baddr; 03024 case 4: 03025 for (id4 = 0; id4 < dimen[3].extent; id4++) { 03026 addr3 = baddr; 03027 case 3: 03028 for (id3 = 0; id3 < dimen[2].extent; id3++) { 03029 addr2 = baddr; 03030 case 2: 03031 for (id2 = 0; id2 < dimen[1].extent; id2++) { 03032 case 1: 03033 if ((element_stride == 1) && (strbegend[0] == 0)) { 03034 ret = _nlread(css, f90type, cup, baddr, 03035 elsize, extent, inc, lastch); 03036 if (ret != 0) goto done; 03037 } 03038 else { 03039 char *ba; 03040 char *newba; 03041 int newelsz; 03042 ba = baddr; 03043 if (strbegend[0] == 0) { 03044 for (id1 = 0; id1 < extent; id1++) { 03045 ret = _nlread(css, f90type, cup, ba, 03046 elsize, 1, 0, lastch); 03047 if (ret != 0) goto done; 03048 ba += dimen[0].stride_mult; 03049 } 03050 } else { 03051 if (begt < 1 ) 03052 begt = 1; 03053 else if (begt > elsize) { 03054 ret = FENLUNKN; 03055 goto done; 03056 } 03057 if (endt < 1 ) 03058 endt = elsize; 03059 else if ((endt > elsize) || (endt < begt)) { 03060 ret = FENLUNKN; 03061 goto done; 03062 } 03063 for (id1 = 0; id1 < extent; id1++) { 03064 newba = ba + (begt - 1); 03065 newelsz = (endt - begt) + 1; 03066 ret = _nlread(css, f90type, cup, 03067 newba, newelsz, 1, 0, lastch); 03068 if (ret != 0) 03069 goto done; 03070 ba += dimen[0].stride_mult; 03071 } 03072 } 03073 } 03074 03075 if (nd == 1) goto done; 03076 baddr += dimen[1].stride_mult; 03077 } 03078 if (nd == 2) goto done; 03079 baddr = addr2; 03080 baddr += dimen[2].stride_mult; 03081 } 03082 if (nd == 3) goto done; 03083 baddr = addr3; 03084 baddr += dimen[3].stride_mult; 03085 } 03086 if (nd == 4) goto done; 03087 baddr = addr4; 03088 baddr += dimen[4].stride_mult; 03089 } 03090 if (nd == 5) goto done; 03091 baddr = addr5; 03092 baddr += dimen[5].stride_mult; 03093 } 03094 if (nd == 6) goto done; 03095 baddr = addr6; 03096 baddr += dimen[6].stride_mult; 03097 } 03098 } 03099 03100 } 03101 else { /* numeric data */ 03102 03103 int bshft; /* 0 or 1; shift count for ratio of */ 03104 /* stride_mult units to basic storage unit */ 03105 /* size. */ 03106 03107 /* 03108 * We only support dopevector stride mults with units 03109 * scaled by sizeof(long) or sizeof(bcont). 03110 */ 03111 #if defined(__mips) || defined(_LITTLE_ENDIAN) || defined(__sv2) 03112 assert( SMSCALE(dv) == sizeof(bcont) || 03113 SMSCALE(dv) == sizeof(_f_int2) || 03114 SMSCALE(dv) == sizeof(_f_int4) || 03115 SMSCALE(dv) == sizeof(long) ); 03116 #else 03117 assert( SMSCALE(dv) == sizeof(bcont) || 03118 SMSCALE(dv) == sizeof(long) ); 03119 #endif 03120 03121 /* the -1 is not possible but check for it */ 03122 assert( SMSHIFT(dv) != -1); 03123 03124 element_stride = 1; 03125 elsize = dv->type_lens.int_len >> 3; 03126 extent = dimen[0].extent; 03127 inc = 0; 03128 bshft = SMSHIFT(dv); 03129 03130 if (extent > 1) { 03131 int bytes_per_sm = dimen[0].stride_mult*(signed)SMSCALE(dv); 03132 inc = bytes_per_sm / elsize; 03133 if (inc * elsize != bytes_per_sm) 03134 element_stride = 0; /* section across derived type */ 03135 } 03136 03137 addr = (bcont*)dv->base_addr.a.ptr + (badjust << bshft); 03138 03139 switch(nd) { 03140 case 7: 03141 for (id7 = 0; id7 < dimen[6].extent; id7++) { 03142 addr6 = addr; 03143 case 6: 03144 for (id6 = 0; id6 < dimen[5].extent; id6++) { 03145 addr5 = addr; 03146 case 5: 03147 for (id5 = 0; id5 < dimen[4].extent; id5++) { 03148 addr4 = addr; 03149 case 4: 03150 for (id4 = 0; id4 < dimen[3].extent; id4++) { 03151 addr3 = addr; 03152 case 3: 03153 for (id3 = 0; id3 < dimen[2].extent; id3++) { 03154 addr2 = addr; 03155 case 2: 03156 for (id2 = 0; id2 < dimen[1].extent; id2++) { 03157 case 1: 03158 if (element_stride) { 03159 ret = _nlread(css, f90type, cup, addr, 03160 elsize, extent, inc, lastch); 03161 } 03162 else { 03163 bcont *ad; 03164 ad = addr; 03165 /* 03166 * If derived type foo contains two fields, 03167 * real a and double precision d, then 03168 * foo(1:2)%d generates this type of 03169 * dopevector with a stride which is not 03170 * a multiple of the element size. 03171 */ 03172 for (id1 = 0; id1 < extent; id1++) { 03173 ret = _nlread(css, f90type, cup, ad, 03174 elsize, 1, 0, lastch); 03175 if (ret != 0) goto done; 03176 ad += dimen[0].stride_mult; 03177 } 03178 } 03179 03180 03181 if (ret != 0) goto done; 03182 03183 if (nd == 1) goto done; 03184 addr += dimen[1].stride_mult << bshft; 03185 } 03186 if (nd == 2) goto done; 03187 addr = addr2; 03188 addr += dimen[2].stride_mult << bshft; 03189 } 03190 if (nd == 3) goto done; 03191 addr = addr3; 03192 addr += dimen[3].stride_mult << bshft; 03193 } 03194 if (nd == 4) goto done; 03195 addr = addr4; 03196 addr += dimen[4].stride_mult << bshft; 03197 } 03198 if (nd == 5) goto done; 03199 addr = addr5; 03200 addr += dimen[5].stride_mult << bshft; 03201 } 03202 if (nd == 6) goto done; 03203 addr = addr6; 03204 addr += dimen[6].stride_mult << bshft; 03205 } 03206 } 03207 } 03208 03209 done: return(ret); 03210 } 03211 03212 static int 03213 _nl_strd_derv( 03214 FIOSPTR css, 03215 unit *cup, 03216 DopeVectorType *dv, 03217 struct DvDimen *sectn, 03218 char *lastch, 03219 nmlist_goli_t *vdr, 03220 unsigned int cnt, 03221 long bte) 03222 { 03223 const int bytesperchar = 1; 03224 int nd; 03225 int i; 03226 long badjust; /* offset for collapsed dims */ 03227 long elsize; /* byte size of each element */ 03228 long ret = 0; 03229 long sizeamt; /* unit for stride mult */ 03230 register long id1, id2, id3, id4, id5, id6, id7; 03231 struct DvDimen *dvdimen; 03232 struct DvDimen dimen[MAXDIM]; 03233 03234 nd = dv->n_dim; 03235 badjust = 0; 03236 03237 /* Make a local copy of dimension information to optimize it. */ 03238 for (i = 0; i < nd; i++) 03239 dimen[i] = dv->dimension[i]; 03240 03241 /* Fold any indexes into the new dimension structure. The 03242 * result is that we can ignore the low_bound field in the 03243 * nested loops. 03244 * 03245 * We also collapse (remove) indexed dimensions and 03246 * unindexed dimensions with extents of one. 03247 */ 03248 dvdimen = dv->dimension; 03249 for (i = 0; i < nd; i++) { 03250 if (sectn == NULL) { 03251 03252 /* bail out here if any extent is 0 */ 03253 if (dvdimen[i].extent == 0) 03254 return(0); 03255 } 03256 else { 03257 /* collapse this indexed dimension */ 03258 badjust += (sectn[i].low_bound - 03259 dvdimen[i].low_bound) * 03260 dvdimen[i].stride_mult; 03261 if (dvdimen[i].extent != sectn[i].extent) 03262 dimen[i].extent = sectn[i].extent; 03263 if (dvdimen[i].stride_mult != sectn[i].stride_mult) 03264 dimen[i].stride_mult = sectn[i].stride_mult; 03265 } 03266 } 03267 03268 elsize = dv->base_addr.a.el_len>> 3; 03269 bte = (badjust * elsize); 03270 if (dv->type_lens.type == DVTYPE_DERIVEDWORD) { 03271 sizeamt = sizeof(int); 03272 } else if (dv->type_lens.type == DVTYPE_DERIVEDBYTE) { 03273 sizeamt = 1 * bytesperchar; 03274 } else { 03275 sizeamt = (signed)SMSCALE(dv); 03276 } 03277 03278 switch(nd) { 03279 case 7: 03280 for (id7 = 0; id7 < dimen[6].extent; id7++) { 03281 case 6: 03282 for (id6 = 0; id6 < dimen[5].extent; id6++) { 03283 case 5: 03284 for (id5 = 0; id5 < dimen[4].extent; id5++) { 03285 case 4: 03286 for (id4 = 0; id4 < dimen[3].extent; id4++) { 03287 case 3: 03288 for (id3 = 0; id3 < dimen[2].extent; id3++) { 03289 case 2: 03290 for (id2 = 0; id2 < dimen[1].extent; id2++) { 03291 case 1: 03292 for (id1 = 0; id1 < dimen[0].extent; id1++) { 03293 ret = _nlrdent(css, cup, vdr, cnt, lastch, bte); 03294 03295 if (ret != 0) goto done; 03296 bte += dimen[0].stride_mult * sizeamt; 03297 } 03298 if (nd == 1) goto done; 03299 bte += dimen[1].stride_mult * sizeamt; 03300 } 03301 if (nd == 2) goto done; 03302 bte += dimen[2].stride_mult * sizeamt; 03303 } 03304 if (nd == 3) goto done; 03305 bte += dimen[3].stride_mult * sizeamt; 03306 } 03307 if (nd == 4) goto done; 03308 bte += dimen[4].stride_mult * sizeamt; 03309 } 03310 if (nd == 5) goto done; 03311 bte += dimen[5].stride_mult * sizeamt; 03312 } 03313 if (nd == 6) goto done; 03314 bte += dimen[6].stride_mult * sizeamt; 03315 } 03316 } 03317 done: return(ret); 03318 }
1.7.6.1 
