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/rnly.c 92.1 06/21/99 10:37:55" 00039 00040 #include <stdio.h> 00041 #include <errno.h> 00042 #include <liberrno.h> 00043 #include <ctype.h> 00044 #include <foreign.h> 00045 #include <fortran.h> /* for _fcdlen() */ 00046 #include <memory.h> 00047 #include <values.h> 00048 #include <stdlib.h> 00049 #include <cray/fmtconv.h> 00050 #include "fio.h" 00051 #include "fmt.h" 00052 #include "rnl.h" 00053 00054 #define BLANK ((int) ' ') 00055 #define NULLC ((int) '\0') 00056 00057 #define OCTAL 1 /* reading octal input */ 00058 #define HEX 2 /* reading hex input */ 00059 #define SKIPMSG " - Skipped record named: " 00060 #define UNITSTR " On Unit: " 00061 00062 struct Echoinfo { 00063 unum_t eunit; /* unit for echoing input */ 00064 int rnlecho;/* 1 if we always echo, 0 if we echo only if 'E' is 00065 * in the first column */ 00066 }; 00067 00068 static void _rnlecho(unum_t _Un, struct Inpinfo *_Ip); 00069 00070 static int _rnl_fillrec(unit *_Cu, struct Echoinfo *_Ec, struct Inpinfo 00071 *_Ip); 00072 00073 static void fmt_unit(char *_Str, void *_U); 00074 00075 static int g_charstr(long _P, int _Cn, char _C, unit *_Cu, struct 00076 Echoinfo *_Ec, struct Inpinfo *_Ip, int _Lc, 00077 int _Sz); 00078 00079 static int g_complx(int _Ty, unit *_Cu, struct Echoinfo *_Ec, struct 00080 Inpinfo *_Ip, long *_Lv); 00081 00082 static int g_number(int _Ty, unit *_Cu, long *_Lv, struct Inpinfo *_Ip); 00083 00084 static int g_octhex(int _Ty, unit *_Cu, struct Echoinfo *_Ec, struct 00085 Inpinfo *_Ip, long *_Lv, int _Base); 00086 00087 static int get_holl(char _Ho, int _Cn, int _Ty, unit *_Cu, struct 00088 Echoinfo *_Ec, struct Inpinfo *_Ip, long *_Lv); 00089 00090 static int get_quoholl(char _Cd, int _Ty, unit *_Cu, struct 00091 Echoinfo *_Ec, struct Inpinfo *_Ip, long *_Lv); 00092 00093 static int isholl(long *_Hp, struct Inpinfo *_Ip); 00094 00095 static int l_convert(long *_Val, int _Ty, long _Stat); 00096 00097 static Nlentry *n_findn(char *_Key, Nlentry *_List); 00098 00099 static int n_getn(char *_S, char *_Lc, unit *_Cu, struct Echoinfo *_Ec, 00100 struct Inpinfo *_Ip); 00101 00102 static int n_getv(Nlentry *_Nlent, char *_Lc, Namelist *_Nlbase, 00103 unit *_Cu, struct Echoinfo *_Ec, struct Inpinfo *_Ip); 00104 00105 static int n_indx(int *_Of, Nlentry *_Nlent, Namelist *_Nlbase, 00106 unit *_Cu, struct Echoinfo *_Ec, struct Inpinfo *_Ip); 00107 00108 static int nex_data(int _Ty, long _Pt, int _Cn, int _In, char _La, 00109 unit *_Cu, struct Echoinfo *_Ec, struct Inpinfo *_Ip, 00110 long *_Lv, int *_Lc, int _Sz); 00111 00112 static int nl_read(long _P, int _Cn, int _In, int _Ty, char *_Lc, 00113 unit *_Cu, struct Echoinfo *_Ec, struct Inpinfo *_Ip, 00114 int _Sz); 00115 00116 static void pr_msg(char *_Str); 00117 00118 static void to_upper(char *_Str); 00119 00120 /* 00121 * TONICV is an interface to NICONV used when reading values. 00122 */ 00123 00124 #define TONICV(value) { \ 00125 inptr->inptr--; \ 00126 inptr->incnt++; /* backup 1 character */ \ 00127 oldp = inptr->inptr; \ 00128 (void) NICONV(oldp, &zero, &zero, &zero, &mode, \ 00129 value, &inptr->inptr, &stat); \ 00130 inptr->incnt -= inptr->inptr - oldp; \ 00131 } 00132 00133 /* 00134 * Use GETSTR to read a character string surrounded by 00135 * quotes or apostrophes. Comment characters are not 00136 * recognized as such inside a quoted string, so LGET is used. 00137 */ 00138 #define GETSTR() { \ 00139 if (inptr->incnt == 1) { \ 00140 LGET(ch); /* skip the blank put in at EOR */\ 00141 } \ 00142 LGET(ch); \ 00143 if (ch == enddelim) { \ 00144 eos = -1; /* end of string */\ 00145 LGET(ch);/* unless the string delimiter is doubled */\ 00146 if (ch == enddelim) \ 00147 eos = 0; \ 00148 else { \ 00149 inptr->inptr--; \ 00150 inptr->incnt++; \ 00151 } \ 00152 } \ 00153 } 00154 00155 00156 static int zero = 0; /* for TONICV */ 00157 00158 00159 /* 00160 * @RNL - read namelist external 00161 * 00162 * @RNL 00163 * read a record into the record buffer 00164 * find namelist delimiter 00165 * read namelist name 00166 * if (not correct namelist name) 00167 * skip the namelist record 00168 * Until we come to a '&' 00169 * read variable name 00170 * find the matching variable descriptor 00171 * get the value(s) for the variable/array 00172 * 00173 * Returns: 0 for success 00174 * 1 for error 00175 * 2 for endfile 00176 * 00177 * in both s1 and s3 (for cft77). 00178 * 00179 * end @RNL 00180 */ 00181 00182 @RNL( 00183 _f_int *unump, /* Unit number */ 00184 Namelist *nl, /* Namelist structure */ 00185 int errf, /* Nonzero if ERR specified */ 00186 int endf /* Nonzero if END specified */ 00187 ) 00188 { 00189 unum_t unum; 00190 int errn; 00191 int i; 00192 int ss; 00193 long stat; 00194 long *hlptr; 00195 Nlentry *nlent; 00196 char buf[MAXNAML + 1], c; 00197 char skipmsg[sizeof(SKIPMSG) + sizeof(UNITSTR) + MAXNAML + 8 + 2]; 00198 char tmpbuf[MXUNITSZ]; /* Unit number buffer for warning messages */ 00199 unit *cup; 00200 FIOSPTR css; 00201 struct Echoinfo echoinfo; 00202 struct Echoinfo *echoptr; 00203 struct Inpinfo ininfo; 00204 struct Inpinfo *inptr; 00205 00206 00207 echoptr = &echoinfo; 00208 unum = *unump; 00209 00210 GET_FIOS_PTR(css); 00211 STMT_BEGIN(unum, 0, T_RNL, NULL, css, cup); 00212 00213 if (cup == NULL) { /* if not connected */ 00214 cup = _imp_open77(css, SEQ, FMT, unum, errf, &errn); 00215 /* 00216 * If the open failed, cup is NULL and errn contains 00217 * the error number. 00218 */ 00219 if (cup == NULL) 00220 RERR(css, errn); 00221 } 00222 00223 /* Set various unit table fields */ 00224 00225 cup->uflag = (errf != 0 ? _UERRF : 0) | (endf != 0 ? _UENDF : 0); 00226 cup->uwrt = 0; /* Clear write flag */ 00227 00228 if (cup->useq == 0) /* If direct access file */ 00229 RERR(css, FESEQTIV); /* Sequential attempted on direct access */ 00230 00231 if (!cup->ufmt) /* If unformatted file */ 00232 RERR(css, FEFMTTIV); /* Formatted attempted on unform.*/ 00233 00234 #if DEBUG 00235 { 00236 int i; 00237 Nlentry *nz; 00238 00239 printf("\n@RNL: ENTER \n"); 00240 printf(" group %s\n", nl->nlname); 00241 00242 nz = nl->nlvnames; 00243 00244 for (i = 0; i < 50; i++, nz++) { 00245 if (!nz->varname[0]) 00246 break; 00247 printf("\n %s: \n", nz->varname); 00248 printf("type:%d (%d) nels:%d ndims:%d taskcm:%d lmf:%d \n", 00249 nz->na.type, _old_namelist_to_f77_type_cnvt[nz->na.type], 00250 nz->na.nels, nz->na.ndims, nz->na.taskcm, nz->na.lmf); 00251 printf("stkf:%d offdim:%o \n", nz->na.stkf, nz->na.offdim); 00252 #ifdef _ADDR64 00253 printf("varaddr:%o\n", nz->va.varaddr); 00254 #else 00255 printf("lmaddr:%o varaddr:%o\n", nz->va.lmaddr, 00256 nz->va.varaddr); 00257 #endif 00258 if (_old_namelist_to_f77_type_cnvt[nz->na.type] == DT_CHAR) { 00259 _fcd *kaddr; 00260 printf("Character variable!,"); 00261 kaddr = (_fcd *) (nz->va.varaddr + (long)nl); 00262 printf("length = %d, waddr = %o, charptr = %o\n", 00263 _fcdlen(*kaddr), kaddr, _fcdtocp(*kaddr)); 00264 } 00265 } 00266 } 00267 #endif 00268 00269 inptr = &ininfo; /* Set up input buffer, pointers */ 00270 inptr->inbuff = cup->ulinebuf; 00271 inptr->inbuff[0]= (long) ' '; /* Carriage control when echoing */ 00272 inptr->incnt = 0; 00273 inptr->inptr = inptr->inbuff + 1; 00274 inptr->instart = inptr->inptr; 00275 00276 (void) strcpy(skipmsg, SKIPMSG); 00277 00278 /* Set up the unit used for echoing input lines */ 00279 00280 if (_OUT_UNIT < 0) { 00281 echoinfo.eunit = 101; /* default = stdout */ 00282 echoinfo.rnlecho = 0; /* no echoing until 'E' in col 1 */ 00283 } 00284 else { 00285 echoinfo.eunit = _OUT_UNIT; 00286 echoinfo.rnlecho = 1; /* echo regardless of flag in col 1 */ 00287 } 00288 00289 if ((cup->uaction & OS_READ) == 0) { 00290 RERR(css, FENOREAD); /* No read permission */ 00291 } 00292 00293 if (cup->uwrt) { 00294 RERR(css, FERDAFWR); /* Read after write */ 00295 } 00296 00297 fill: 00298 ss = _rnl_fillrec(cup, &echoinfo, inptr); 00299 00300 if (ss != 0) 00301 goto err_eof; 00302 00303 fill1: 00304 do { 00305 MAINCMNTLGET(c) 00306 } while (ISSPTB(c)); 00307 00308 if (!MATCH(c, _MASKS, MRNLDELIM)) 00309 goto fill; /* Assume a comment statement */ 00310 00311 MAINLGET(c); 00312 00313 ss = n_getn(buf, &c, cup, &echoinfo, inptr); 00314 00315 if (ss != 0) 00316 goto err_eof; 00317 00318 to_upper(buf); 00319 00320 if (strcmp(nl->nlname, buf)) { /* group name unmatched */ 00321 if (_SKP_MESS > 0) { 00322 00323 /* Skip the record and issue a logfile message */ 00324 00325 (void) strcpy(&skipmsg[sizeof(SKIPMSG)-1], buf); 00326 (void) strcat(skipmsg, UNITSTR); 00327 fmt_unit(tmpbuf, unump); 00328 /* 00329 * The following truncates the file name/unit number 00330 * to seven characters, which will result in a loss 00331 * of information when the unit number is larger than 00332 * 9,999,999. 00333 */ 00334 (void) strncat(skipmsg, tmpbuf, sizeof(long) - 1); 00335 (void) strcat(skipmsg, "\n"); 00336 pr_msg(skipmsg); 00337 } 00338 else if (_SKP_MESS < 0) { 00339 /* Aborts the job or goes to the optional ERR= branch */ 00340 RERR(css, FENLIVGN); 00341 } 00342 del_look: 00343 /* Read until we find a delimiter */ 00344 00345 while (!MATCH(c, _MASKS, MRNLDELIM) && c!= '/') { 00346 00347 if (c == '\'' || c == '"') { 00348 char qchar; 00349 00350 qchar = c; 00351 rquote: 00352 do { 00353 MAINLGET(c); 00354 } while (c != qchar); 00355 00356 MAINLGET(c); /* See if it's a double quote */ 00357 00358 if (c == qchar) 00359 goto rquote; 00360 } 00361 else { 00362 MAINCMNTLGET(c); 00363 } 00364 } 00365 00366 /* 00367 * Try to determine whether this delimiter is part of a 00368 * Hollerith string by looking back in the line. If it 00369 * is part of a Hollerith string, it's not really an 00370 * end delimiter. 00371 */ 00372 00373 hlptr = inptr->inptr - 2; 00374 00375 /* 00376 * Search for nH, nh, nl, nL, nr, nR where n is a digit. 00377 * Only look back 8 characters or to the beginning of 00378 * this line of input 00379 */ 00380 00381 for (i = 0; i < 8 && hlptr > &inptr->inbuff[2]; i++, hlptr--) { 00382 switch((char) *hlptr) { 00383 case 'h': 00384 case 'H': 00385 case 'l': 00386 case 'L': 00387 case 'r': 00388 case 'R': 00389 if (isholl(hlptr, inptr)) { 00390 MAINCMNTLGET(c); 00391 goto del_look; 00392 } 00393 break; 00394 00395 default: 00396 break; 00397 } /* switch */ 00398 } 00399 goto fill1; 00400 } 00401 00402 /* 00403 * Have found the correct namelist group. 00404 * Process the input record. Read until we 00405 * see trailing delimiter. 00406 */ 00407 while (!MATCH(c, _MASKS, MRNLDELIM) && (c != '/')) { 00408 int sepcnt; 00409 00410 ss = n_getn(buf, &c, cup, &echoinfo, inptr); 00411 00412 if (ss != 0) 00413 goto err_eof; 00414 00415 to_upper(buf); 00416 00417 if (!(nlent = n_findn(buf, nl->nlvnames))) 00418 if (strlen(buf) > 0) { 00419 RERR2(css, FENLNREC, buf); /* variable not found */ 00420 } 00421 else { 00422 Nreturn(IO_OKAY); /* empty variable entry */ 00423 } 00424 00425 /* we're positioned just after the var/array name */ 00426 00427 /* get value(s) */ 00428 00429 ss = n_getv(nlent, &c, nl, cup, &echoinfo, inptr); 00430 00431 if (ss != 0) 00432 goto err_eof; 00433 00434 sepcnt = 0; 00435 00436 for ( ; ; ) { 00437 00438 if (!(ISSPTB(c))) { 00439 00440 if ((MATCH(c, _MASKS, MRNLSEP)) && 00441 (sepcnt == 0)) 00442 sepcnt++; /* skip 1 separator */ 00443 else 00444 break; 00445 } 00446 00447 MAINCMNTLGET(c); 00448 } 00449 } 00450 00451 ret: /* Return to user */ 00452 00453 STMT_END(cup, T_RNL, NULL, css); /* unlock the unit */ 00454 00455 return(CFT77_RETVAL(ss)); 00456 00457 err_eof: /* Handle EOF or error */ 00458 00459 if (ss == EOF) { 00460 NEND(css, FERDNLEF); 00461 } 00462 else { 00463 if (errno == FENLTYPI) { 00464 RERR3(css, errno, nlent->varname, 00465 _f77_type_name[_old_namelist_to_f77_type_cnvt[nlent->na.type]]); 00466 } 00467 else 00468 RERR(css, errno); 00469 } 00470 00471 goto ret; 00472 } 00473 00474 /* 00475 * n_getn - Get variable name or group name 00476 * 00477 * On entry: 00478 * - we're positioned to name possibly preceeded by blanks 00479 * 00480 * On exit: 00481 * - we return 0 if success 00482 * EOF if end of file read 00483 * RNL_ERROR if other error (errno will be set) 00484 * - we're positioned just after the name. 00485 * - *lastc contains the last character read. 00486 * 00487 * In looking for the name, we stop when we see a 00488 * space, replacement character ('='), or '(', or delimiter ('&') 00489 */ 00490 00491 static int 00492 n_getn( 00493 char *s, 00494 char *lastc, 00495 unit *cup, 00496 struct Echoinfo *echoptr, 00497 struct Inpinfo *inptr 00498 ) 00499 { 00500 char *p, c; 00501 int n; 00502 int ss; 00503 00504 n = MAXNAML; 00505 p = s; 00506 c = *lastc; 00507 00508 while (ISSPTB(c)) 00509 CMNTLGET(c); 00510 00511 /* 00512 * Names can never have embedded blanks. 00513 * A comment can immediately follow the name 00514 * and will terminate it. 00515 */ 00516 00517 while (!(ISSPTB(c)) && c != '(' && !(MATCH(c, _MASKS, MRNLREP)) && 00518 !(MATCH(c, _MASKS, MRNLDELIM))) { 00519 00520 *p++ = c; 00521 00522 CMNTLGET(c); 00523 00524 if (n-- == 0) { 00525 RNLERROR(FENLLONG); /* name too long */ 00526 } 00527 } 00528 00529 *lastc = c; 00530 *p = '\0'; 00531 00532 return (0); 00533 } 00534 00535 /* 00536 * n_findn - find variable name in list of Nlentrys 00537 * 00538 * Returns: 00539 * pointer to matching variable descriptor or 00540 * NULL if variable name was not found. 00541 */ 00542 00543 static Nlentry 00544 *n_findn( 00545 char *key, /* Pointer to variable name we're searching for */ 00546 Nlentry *list 00547 ) 00548 { 00549 while (strlen(list->varname) > 0) { 00550 if (!strcmp(key, list->varname)) 00551 return (list); 00552 else 00553 list++; 00554 } 00555 00556 return (NULL); 00557 } 00558 00559 /* n_getv - get values for namelist io 00560 * 00561 * n_getv uses nl_read to do all the dirty work 00562 * 00563 * On entry: 00564 * - positioned just after the variable/array name 00565 * - lastc contains the character following variable/array name 00566 * 00567 * On exit: 00568 * - *lastc contains the character following the value 00569 * - inptr is pointing to the character following that 00570 * - returns 00571 * 0 if success 00572 * -1 if EOF detected 00573 * valid error number if error detected 00574 */ 00575 00576 static int 00577 n_getv( 00578 Nlentry *nlent, 00579 char *lastc, 00580 Namelist *nlbase, 00581 unit *cup, 00582 struct Echoinfo *echoptr, 00583 struct Inpinfo *inptr 00584 ) 00585 { 00586 long ss, cnt; 00587 long stat; 00588 int offset, size, ret; 00589 char *cp; 00590 long vaddr; 00591 00592 /* 00593 * find the offset in the case of an indexed array 00594 */ 00595 if (*lastc == '(') { 00596 00597 ret = n_indx(&offset, nlent, nlbase, cup, echoptr, inptr); 00598 00599 if (ret != 0) 00600 return(ret); 00601 } 00602 else { /* get to the '=' */ 00603 offset = 0; 00604 00605 while (ISSPTB(*lastc)) { 00606 CMNTLGET(*lastc); 00607 } 00608 00609 if (!(MATCH(*lastc, _MASKS, MRNLREP))) { /* match '=' */ 00610 RNLERROR(FENLNOVL); 00611 } 00612 } 00613 00614 /* Now we're positioned after the '=' */ 00615 00616 /* 00617 * Compute: 00618 * cnt number of array elements to be read (1 if not an array). 00619 * size size of the variable or array element (words for nonchar, 00620 * bytes for char). 00621 * vaddr the pointer to common memory where data is to be transferred. 00622 * For type DT_CHAR, this is a Fortran character descriptor. 00623 */ 00624 00625 if (nlent->na.offdim == 0) /* variable */ 00626 cnt = 1; 00627 else /* complete array, adjusted for any dimension */ 00628 cnt = nlent->na.nels - offset; 00629 00630 if (_old_namelist_to_f77_type_cnvt[nlent->na.type] == DT_CHAR) { 00631 _fcd f; 00632 00633 /* get Fortran character descriptor */ 00634 f = *(_fcd *) ((unsigned long) nlent->va.varaddr + 00635 (long) nlbase); 00636 /* get character element length */ 00637 size = _fcdlen(f); 00638 /* calculate character address as c pointer */ 00639 cp = _fcdtocp(f) + (offset * size); 00640 f = _cptofcd(cp, size); 00641 /* pass character pointer and element size as args */ 00642 vaddr = (long) cp; 00643 } 00644 else { 00645 size = _f77_type_len[_old_namelist_to_f77_type_cnvt[nlent->na.type]] >> 3; 00646 vaddr = (long)nlent->va.varaddr + offset * size; 00647 } 00648 00649 ss = nl_read(vaddr, cnt, 1, _old_namelist_to_f77_type_cnvt[nlent->na.type], 00650 lastc, cup, echoptr, inptr, size); 00651 00652 return(ss); 00653 } 00654 00655 /* n_indx - calculate the offset of the indexed array 00656 * 00657 * On entry: 00658 * - positioned just after the '(' 00659 * 00660 * On exit: 00661 * - returns: 00662 * 0 on success 00663 * -1 on eof 00664 * RNL_ERROR on error (errno is set) 00665 * - positioned just after the '=' 00666 * - the "lastc" argument is not changed 00667 * 00668 */ 00669 00670 static int 00671 n_indx( 00672 int *offset, 00673 Nlentry *nlent, 00674 Namelist *nlbase, 00675 unit *cup, 00676 struct Echoinfo *echoptr, 00677 struct Inpinfo *inptr 00678 ) 00679 { 00680 long subs[MAXDIMS]; /* subscripts */ 00681 long *oldp, *newp; 00682 long mode, ss; 00683 long offs, mult; 00684 char c; 00685 Dims *p; 00686 int i, j; 00687 long stat; 00688 long vaddr; 00689 00690 /* Get the indices */ 00691 00692 mode = 0; 00693 00694 for (i = 0; i < MAXDIMS; ) { 00695 long dummy; 00696 00697 do { 00698 LGET(c); /* Not OK for comments here */ 00699 } while (ISSPTB(c)); 00700 00701 if (c == ')') 00702 break; 00703 00704 inptr->incnt++; 00705 inptr->inptr--; 00706 00707 /* Get the subscript */ 00708 00709 oldp = inptr->inptr; 00710 00711 #if 0 00712 dummy = 0; 00713 00714 (void) NICONV(oldp, &dummy, &dummy, &dummy, &mode, &subs[i], 00715 &newp, &stat); 00716 00717 if (stat != NV32I) { 00718 RNLERROR(FENLBNDY); 00719 } 00720 #else 00721 00722 for (j = 0; j < inptr->incnt; j++) { 00723 00724 c = (char) oldp[j]; 00725 00726 if (c == ')' || c == ',') 00727 break; 00728 } 00729 00730 newp = oldp + j; 00731 00732 (void) _iu2s(oldp, &inptr->incnt, &newp, &mode, &subs[i], 00733 &stat, &dummy, &dummy); 00734 00735 if (stat < 0) { 00736 RNLERROR(FENLBNDY); /* is there a better error? */ 00737 } 00738 00739 #if defined(_CRAY1) || defined(_WORD32) 00740 if (stat != EX_INTS) { 00741 RNLERROR(FENLBNDY); 00742 } 00743 #endif 00744 00745 #endif 00746 00747 inptr->inptr = newp; 00748 inptr->incnt = inptr->incnt - (newp - oldp); 00749 00750 i++; /* increment the number of subscripts */ 00751 00752 do { 00753 LGET(c); /* get to ',' or ')' */ 00754 } while (ISSPTB(c)); /* NOT OK to have an EOR here */ 00755 00756 if (c == ')') 00757 break; 00758 00759 if (c != ',') { 00760 RNLERROR(FENLIOER); /* bad character */ 00761 } 00762 } 00763 00764 if (i == 0) { 00765 RNLERROR(FENLIOER); /* null index */ 00766 } 00767 00768 while (!(MATCH(c, _MASKS, MRNLREP))) { /* Look for the replacement */ 00769 LGET(c); 00770 } 00771 00772 /* 00773 * compute the offset of the array element 00774 */ 00775 00776 p = (Dims *)(nlent->na.offdim + (long)nlbase); 00777 mult = 1; 00778 00779 offs = subs[0] - p[0].lower; 00780 00781 /* 00782 * for example: a three dimension array in Fortran column major format 00783 * offs = span[0] * span[1] * (sub[2] - p[2].lower) 00784 * span[0] * (sub[1] - p[1].lower) 00785 * (sub[0] - p[0].lower) 00786 */ 00787 00788 /* 00789 * Check that we did not read in more dimensions than 00790 * we should have. 00791 */ 00792 00793 if (i > nlent->na.ndims) { 00794 RNLERROR(FENLBNDY); 00795 } 00796 00797 for (j = 1; j < i; j++) { 00798 mult = mult * p[j-1].span; 00799 offs = offs + ((subs[j] - p[j].lower) * mult); 00800 } 00801 00802 /* Check that the dimension read is not too large */ 00803 00804 if (offs >= nlent->na.nels) { 00805 RNLERROR(FENLBNDY); 00806 } 00807 00808 *offset = offs; 00809 00810 return(0); 00811 } 00812 00813 /* 00814 * Echo the line in inptr->inbuff. 00815 */ 00816 00817 static void 00818 _rnlecho( 00819 unum_t eunit, /* Unit for echoing */ 00820 struct Inpinfo *inptr 00821 ) 00822 { 00823 unit *echoup; 00824 FIOSPTR css; 00825 GET_FIOS_PTR(css); 00826 00827 echoup = _get_cup(eunit); /* lock the unit */ 00828 00829 if (echoup == NULL) { 00830 unit *cupsave; 00831 00832 cupsave = css->f_cu; /* Save for _imp_open() */ 00833 echoup = _imp_open77(css, SEQ, FMT, eunit, 1, NULL); 00834 css->f_cu = cupsave; 00835 00836 if (echoup == NULL) /* If OPEN failed */ 00837 return; 00838 } 00839 else { 00840 00841 if (echoup->ufmt == 0) /* If unformatted file */ 00842 _ferr(css, FEFMTTIV); 00843 00844 if (echoup->useq == 0) /* If direct access file */ 00845 _ferr(css, FESEQTIV); 00846 } 00847 00848 /* 00849 * Output the blank that precedes the buffer for carriage control 00850 * Add one to incnt, so that the preceding blank is counted. 00851 */ 00852 00853 (void) _fwch(echoup, inptr->inbuff, inptr->incnt + 1, FULL); 00854 00855 (void) _release_cup(echoup); /* unlock the unit */ 00856 00857 return; 00858 } 00859 00860 /* 00861 * Formats the unit number or file name and copies to 'string'. 00862 */ 00863 00864 static void 00865 fmt_unit( 00866 char *string, 00867 void *u 00868 ) 00869 { 00870 register unum_t unum; 00871 00872 if (_is_file_name(*((long *)u))) 00873 (void) strncpy(string, (char *)u, sizeof(long) - 1); 00874 else { 00875 unum = *((unum_t *)u); 00876 (void) sprintf(string, "%lld", unum); 00877 } 00878 00879 return; 00880 } 00881 00882 /* 00883 * Converts the string in buf to upper case letters 00884 */ 00885 00886 static void 00887 to_upper(char *buf) 00888 { 00889 char c; 00890 00891 while ((c = *buf) != '\0') { 00892 *buf++ = toupper(c); 00893 } 00894 00895 return; 00896 } 00897 00898 /* 00899 * nl_read is used to read and store values for the data item. 00900 * 00901 * On input, inptr points to the character immediately following the '=' 00902 * 00903 * On exit, lastc will contain the first nonblank, nonseparator character 00904 * following the value. 00905 */ 00906 00907 static int 00908 nl_read( 00909 long ptr, /* Address of the data item */ 00910 int count, /* Number of values to read */ 00911 int inc, /* Always 1 on input */ 00912 int type, /* Type of the data item */ 00913 char *lastc, /* On exit, lastc contains the first 00914 nonblank, nonseparator character 00915 following the value */ 00916 unit *cup, /* Pointer to unit table */ 00917 struct Echoinfo *echoptr, 00918 struct Inpinfo *inptr, 00919 int elsize /* declared size of char item */ 00920 ) 00921 { 00922 int ss; 00923 int cntp; 00924 int nullvlu; /* Indicates whether null values were found */ 00925 char *cp; 00926 long stat; 00927 long lval[3]; /* NICONV requires an extra word here */ 00928 int lcount; /* Repeat count for values */ 00929 00930 if ((type < 0) || (type >= DT_MAX)) 00931 RNLERROR(FEINTDTY); /* type error */ 00932 00933 if (type == DT_CMPLX || type == DT_DBLE) 00934 inc = inc + inc; 00935 00936 CMNTLGET(*lastc); /* Get the first character */ 00937 00938 lcount = 0; /* Repeat count */ 00939 cntp = count; 00940 00941 while (cntp > 0) { 00942 00943 if (cup->uend) 00944 return(EOF); 00945 00946 /* get next data group */ 00947 00948 nullvlu = nex_data(type, ptr, cntp, inc, *lastc, cup, echoptr, 00949 inptr, lval, &lcount, elsize); 00950 00951 if (nullvlu == RNL_ERROR) { 00952 return(RNL_ERROR); 00953 } 00954 else if (nullvlu == 2) { /* No more values for this variable */ 00955 lcount = 0; 00956 cntp = 0; 00957 } 00958 00959 if (type == DT_CHAR) { 00960 /* 00961 * Character data is already in place. 00962 * Adjust ptr and cntp. 00963 */ 00964 00965 if (lcount > cntp) 00966 RNLERROR(FENLTOOM); /* too many elements specified */ 00967 /* ptr is a c pointer. When the data type is 00968 * character, the declared length is passed in 00969 * argument size. An fcd is not passed. 00970 */ 00971 cp = (char *) ptr; 00972 cntp = cntp - lcount; 00973 00974 cp = cp + (lcount * elsize); 00975 ptr = (long) cp; 00976 00977 } 00978 00979 else { 00980 int move; 00981 00982 move = MIN(cntp, lcount); 00983 00984 /* Move what's needed from data group */ 00985 00986 while (move != 0) { 00987 if (!nullvlu) { /* move data in, unless nulls */ 00988 *(long *)ptr = lval[0]; 00989 if ((type == DT_DBLE) || 00990 (type == DT_CMPLX)) 00991 *((long *)ptr+1) = lval[1]; 00992 } 00993 00994 ptr = ptr + inc; 00995 move = move - 1; 00996 cntp = cntp - 1; 00997 lcount = lcount - 1; 00998 } 00999 01000 if (lcount) 01001 RNLERROR(FENLTOOM); /* too many elements specified */ 01002 } 01003 01004 /* 01005 * nex_data() will have positioned us at the first character 01006 * following the value. Read this character so that we can 01007 * skip trailing blanks and the trailing separator, if any. 01008 */ 01009 01010 do { 01011 CMNTLGET(*lastc); 01012 } while (ISSPTB(*lastc)); 01013 01014 if (MATCH(*lastc, _MASKS, MRNLSEP)) { 01015 do { 01016 CMNTLGET(*lastc); 01017 } while (ISSPTB(*lastc)); 01018 } 01019 } 01020 01021 return(0); 01022 } 01023 01024 /* nex_data - get the next data group 01025 * 01026 * On return, lval will contain the value and lcount the repeat count 01027 * Outptr will point to character immediately following value 01028 * 01029 * The return value is: -1 for EOF 01030 * 0 for ok 01031 * 1 for null value read 01032 * 2 for null value, followed by possible 01033 * variable name 01034 * valid error number if an error 01035 */ 01036 01037 static int 01038 nex_data( 01039 int type, /* Type of data item */ 01040 long ptr, /* Address of data item */ 01041 int cnt, /* Number of values to look for */ 01042 int inc, 01043 char lastc, /* First character of value (may be blank) */ 01044 unit *cup, /* Input unit */ 01045 struct Echoinfo *echoptr, 01046 struct Inpinfo *inptr, /* Describes input buffer */ 01047 long *lval, /* Value is placed here */ 01048 int *lcount, /* Repeat count is returned here */ 01049 int elsize /* declared size of character item */ 01050 ) 01051 { 01052 char c, oc; 01053 int ocnt, ss; 01054 long *optr; 01055 int holcnt; /* Length of hollerith string */ 01056 long stat; 01057 char newc; 01058 01059 c = lastc; 01060 01061 while (ISSPTB(c)) { 01062 CMNTLGET(c); 01063 } 01064 01065 *lcount = 1; /* set repeat count */ 01066 01067 if (isdigit((int) c)) { 01068 01069 /* 01070 * Look for repeat count. We can have a repeat count 01071 * for any type of data, including character. 01072 */ 01073 01074 *lcount = c - '0'; 01075 ocnt = inptr->incnt; /* save count and pointer, in case */ 01076 optr = inptr->inptr; /* this isn't repeat count */ 01077 oc = c; 01078 01079 for (;;) { 01080 01081 LGET(c); /* Ignore comments while doing this */ 01082 01083 if (isdigit((int) c)) 01084 *lcount = (*lcount * 10) + c - '0'; 01085 else 01086 break; 01087 } 01088 01089 /* 01090 * Could have r*c, rH, rL, or rR, where r is the number just 01091 * read. No embedded blanks are allowed in r*c, rH, rL, or rR. 01092 */ 01093 01094 switch (c) { 01095 01096 case '*': 01097 CMNTLGET(c); /* Get next character. */ 01098 01099 if (isdigit((int) c)) { 01100 /* See if we have a repeat count 01101 * followed by hollerith, like 01102 * 3*4Habcd 01103 */ 01104 holcnt = c - '0'; 01105 ocnt = inptr->incnt; 01106 optr = inptr->inptr; 01107 oc = c; 01108 01109 for (;;) { 01110 01111 LGET(c); 01112 01113 if (isdigit((int) c)) 01114 holcnt = (holcnt * 10) + 01115 c - '0'; 01116 else 01117 break; 01118 } 01119 01120 switch (c) { 01121 case 'H': 01122 case 'h': 01123 case 'R': 01124 case 'r': 01125 case 'L': 01126 case 'l': 01127 return(get_holl(c, 01128 holcnt, type, 01129 cup, echoptr, 01130 inptr, lval)); 01131 01132 default: 01133 /* backup restore */ 01134 inptr->inptr = optr; 01135 /* cnt and ptr */ 01136 inptr->incnt = ocnt; 01137 c = oc; 01138 ocnt = 1; 01139 break; 01140 01141 } /* switch */ 01142 } 01143 break; /* Ordinary repeat count */ 01144 01145 case 'H': 01146 case 'h': 01147 case 'R': 01148 case 'r': 01149 case 'L': 01150 case 'l': 01151 /* 01152 * Assuming we have a Hollerith string, like 3Habc 01153 */ 01154 holcnt = *lcount; 01155 *lcount = 1; /* No repeats */ 01156 01157 return(get_holl(c, holcnt, type, cup, echoptr, 01158 inptr, lval)); 01159 01160 default: 01161 /* No repeat count, backup restore, cnt & ptr */ 01162 inptr->inptr = optr; 01163 inptr->incnt = ocnt; 01164 c = oc; 01165 ocnt = 1; 01166 *lcount = 1; 01167 break; 01168 } /* switch */ 01169 } 01170 01171 /* 01172 * Looking for a value. When we get here we are at a nonblank 01173 * character, unless we had the form r*, in which case it may 01174 * be followed by a blank (NULL). 01175 */ 01176 01177 if (MATCH(c, _MASKS, MRNLSEP)) { 01178 inptr->inptr--; /* reset cnt and ptr so */ 01179 inptr->incnt++; /* we can read separator again */ 01180 return(1); /* return null value */ 01181 } 01182 else if (ISSPTB(c)) { 01183 return(1); /* return null value */ 01184 } 01185 01186 else 01187 if (MATCH(c, _MASKS, MRNLCOMM)) { 01188 /* 01189 * The only time we would see this is if we have 01190 * input like: A = 5*; 01191 */ 01192 01193 *lval = *(lval+1) = 0; 01194 inptr->incnt++; /* reset cnt and ptr so rest on line */ 01195 inptr->inptr--; /* is read in a null values */ 01196 return(1); /* return null value */ 01197 } 01198 else 01199 if (MATCH(c, _MASKS, MRNLDELIM)) { 01200 inptr->inptr--; /* reset cnt and ptr so */ 01201 inptr->incnt++; /* read delimiter again */ 01202 return(2); /* Return null value */ 01203 } 01204 /* 01205 * It is important that we handle the special cases of types logical 01206 * and character first, because the format of their data is treated 01207 * differently. 01208 */ 01209 01210 if (type == DT_LOG) { 01211 /* Looking for a logical value. Logical values must be of 01212 * the form: optional decimal point, followed by a 'T' for 01213 * true or an 'F' for false, optionally followed by one 01214 * or more additional characters. Those additional 01215 * characters cannot include '=', ',', ':', ';', '(', '$' 01216 * or '&'. 01217 */ 01218 if (c == '.') { 01219 01220 LGET(c); 01221 01222 if ((c == 'T') || (c == 't')) { 01223 /* .T or .t assumed to be a logical value */ 01224 *lval = (long) TRUE; 01225 } 01226 else if ((c == 'F') || (c == 'f')) { 01227 /* .F or .f assumed to be a logical value */ 01228 *lval = (long) FALSE; 01229 } 01230 else 01231 RNLERROR(FENLIVLG); /* Invalid logical */ 01232 } 01233 01234 else { 01235 /* 01236 * If the string does not start with a '.', it could 01237 * be a logical value or a variable name. Try to 01238 * determine which by seeing if it is followed by a 01239 * replacement character or '('. Save count and 01240 * pointer in case this isn't a value. 01241 */ 01242 01243 ocnt = inptr->incnt; 01244 optr = inptr->inptr; 01245 newc = *optr++; 01246 ocnt--; 01247 01248 while (!(ISSPTB(newc))) { 01249 if (MATCH(newc, _MASKS, MRNLSEP) || 01250 MATCH(newc, _MASKS, MRNLDELIM)) 01251 break; /* Assume value */ 01252 if (MATCH(newc, _MASKS, MRNLREP) || 01253 (newc == '(')) { 01254 /* 01255 * Reset, because this MAY have been 01256 * the first letter of a variable name 01257 */ 01258 inptr->inptr--; 01259 inptr->incnt++; 01260 return(2); /* Null value */ 01261 } 01262 newc = *optr++; 01263 ocnt--; 01264 } 01265 01266 while ((ISSPTB(newc)) && ocnt-- > 0) 01267 newc = *optr++; 01268 01269 if (MATCH(newc, _MASKS, MRNLREP)) { 01270 /* 01271 * Reset, because this MAY have been 01272 * the first letter of a variable name 01273 */ 01274 inptr->inptr--; 01275 inptr->incnt++; 01276 return(2); /* Null value */ 01277 } 01278 01279 if ((c == 'T') || (c == 't')) { 01280 *lval = (long) TRUE; 01281 } 01282 else if ((c == 'F') || (c == 'f')) { 01283 *lval = (long) FALSE; 01284 } 01285 else if (ISSPTB(c) || (MATCH(c, _MASKS, MRNLSEP))) { 01286 return(1); /* Indicate null value */ 01287 } 01288 else { 01289 RNLERROR(FENLIVLG); /* Invalid logical */ 01290 } 01291 } 01292 /* 01293 * We assume we're reading a logical value. 01294 * Skip to the end of this value. 01295 */ 01296 01297 while ( !(ISSPTB(c))) { 01298 01299 CMNTLGET(c); 01300 01301 if (MATCH(c, _MASKS, MRNLDELIM) || 01302 MATCH(c, _MASKS, MRNLSEP)) { 01303 /* 01304 * Reset cnt and prt so this will be read and 01305 * handled correctly. 01306 */ 01307 inptr->inptr--; 01308 inptr->incnt++; 01309 01310 return(0); /* return logical value */ 01311 } 01312 01313 } 01314 return(0); /* return logical value */ 01315 01316 } /* End of type logical */ 01317 01318 if (type == DT_CHAR) /* Read character data */ 01319 return (g_charstr(ptr, cnt, c, cup, echoptr, inptr, *lcount, elsize)); 01320 01321 /* 01322 * Get value for variable that is not type LOGICAL or CHARACTER 01323 */ 01324 01325 if (isdigit((int) c) || c == '+' || c == '-' || c == '.') { 01326 01327 if (type == DT_CMPLX) 01328 RNLERROR(FENLIVCX); 01329 01330 return(g_number(type, cup, lval, inptr)); 01331 } 01332 01333 /* 01334 * When we get here we are looking for a VALUE. We are at a 01335 * nonblank character which is not a digit, +, or -, separator, 01336 * comment or delimiter. 01337 */ 01338 01339 if (c == '(') { 01340 return(g_complx(type, cup, echoptr, inptr, lval)); 01341 } 01342 else if ((c == '\'') || (c == '"')) { /* look for Hollerith string */ 01343 return(get_quoholl(c, type, cup, echoptr, inptr, lval)); 01344 } 01345 01346 else if (c == 'O' || c == 'o') { /* look for octal number */ 01347 return(g_octhex(type, cup, echoptr, inptr, lval, OCTAL)); 01348 } 01349 else if (c == 'Z' || c == 'z') { /* look for hexadecimal number */ 01350 return(g_octhex(type, cup, echoptr, inptr, lval, HEX)); 01351 } 01352 else { 01353 /* 01354 * No valid value. 01355 * Reset inptr, because this MAY have been the first 01356 * character of a variable name. 01357 * For example, if we have: integer var1(3),var2, with input: 01358 * var1 = 2, var2 = 5 01359 * then when we try to read the value for var1(2), we will see 01360 * 'var2' 01361 */ 01362 01363 inptr->inptr--; 01364 inptr->incnt++; 01365 01366 return(2); /* Return null value */ 01367 } 01368 } 01369 01370 /* 01371 * Get the value for a complex number. 01372 * On entry, we are at '(' in the representation of a complex number. 01373 * 01374 * Returns: 0 if OK, 01375 * -1 if EOF 01376 * valid error number if an error 01377 */ 01378 01379 static int 01380 g_complx( 01381 int type, 01382 unit *cup, 01383 struct Echoinfo *echoptr, 01384 struct Inpinfo *inptr, 01385 long *lval 01386 ) 01387 { 01388 char c; 01389 long *oldp; 01390 long mode, stat; 01391 int ss, i; 01392 01393 /* 01394 * IN reading the complex number, assume 01395 * intervening EOR is OK 01396 */ 01397 01398 if (type != DT_CMPLX) { 01399 RNLERROR(FENLTYPI); /* type mismatch */ 01400 } 01401 01402 mode = 0; 01403 01404 /* 01405 * If the user had turned off blanks as separator, tell 01406 * NICONV to ignore them. Otherwise, blanks are significant. 01407 */ 01408 01409 if (_BLNKSEP == 0) 01410 mode |= MBN; 01411 01412 /* loop and get both real and imaginary */ 01413 01414 for (i = 0; i < 2; i++) { 01415 01416 do { 01417 LGET(c); /* skip the '(' */ 01418 } while (ISSPTB(c)); /* skip blanks */ 01419 01420 TONICV(lval + i); /* convert real/imaginary part */ 01421 01422 if (l_convert(lval + i, DT_REAL, stat)) /* make &lval[0] real */ 01423 RNLERROR(FENLTYPI); /* type mismatch */ 01424 01425 do { 01426 LGET(c); 01427 } while (ISSPTB(c)); 01428 01429 if ((c != ',') && (i == 0)) { 01430 RNLERROR(FENLIVCX); /* error in complex number 01431 * format */ 01432 } 01433 } 01434 01435 if ( c != ')') { 01436 RNLERROR(FENLIVCX); /* error in complex number format */ 01437 } 01438 01439 return(0); 01440 } 01441 01442 /* 01443 * Read a number. 01444 * 01445 * Returns: 0 if ok 01446 * -1 if EOF 01447 * RNL_ERROR if error (errno is set) 01448 */ 01449 01450 static int 01451 g_number( 01452 int type, 01453 unit *cup, 01454 long *lval, 01455 struct Inpinfo *inptr 01456 ) 01457 { 01458 long *oldp; 01459 long mode, stat; 01460 int ss; 01461 01462 mode = 0; 01463 01464 if (type == DT_DBLE) 01465 mode |= MD; 01466 01467 /* 01468 * If the user had turned off blanks as separator, tell NICONV 01469 * to ignore them. Otherwise, blanks are significant. 01470 */ 01471 01472 if (_BLNKSEP == 0) 01473 mode |= MBN; 01474 01475 TONICV(lval); 01476 01477 if (l_convert(lval, type, stat)) { 01478 RNLERROR(FENLTYPI); 01479 } 01480 01481 return(0); 01482 } 01483 01484 /* 01485 * Convert value read to proper type for storage. 01486 * If _TYP_CONV indicates, issue an error when 01487 * value read does not match type of variable. 01488 * 01489 * returns: 0 if conversion was ok 01490 * RNL_ERROR if error 01491 */ 01492 01493 static int 01494 l_convert( 01495 long *val, 01496 int type, /* Data type */ 01497 long stat 01498 ) 01499 { 01500 short sval; 01501 long lval; 01502 union { 01503 long l; 01504 double f; 01505 } uval; 01506 01507 if (stat <= 0 || stat > NVDOUB) 01508 return(RNL_ERROR); 01509 01510 /* 01511 * Switch on value read type 01512 */ 01513 01514 switch (stat) { 01515 01516 case NV32I: 01517 case NV64I: 01518 /* 01519 * Value read is integer. 01520 */ 01521 switch (type) { 01522 case DT_SINT: 01523 case DT_INT: 01524 break; 01525 01526 case DT_REAL: 01527 case DT_DBLE: 01528 if (!_TYP_CONV) 01529 return(RNL_ERROR); 01530 01531 uval.f = (double) *val; 01532 *val = uval.l; 01533 break; 01534 01535 case DT_LOG: 01536 default: 01537 /* Can't convert to logical or character */ 01538 return(RNL_ERROR); 01539 } 01540 break; 01541 01542 case NVREAL: 01543 case NVDOUB: 01544 /* 01545 * Value read is real. 01546 */ 01547 uval.l = *val; 01548 01549 switch (type) { 01550 case DT_SINT: 01551 if (!_TYP_CONV) 01552 return(RNL_ERROR); 01553 01554 sval = (short) uval.f; 01555 *val = sval; 01556 break; 01557 01558 case DT_INT: 01559 if (!_TYP_CONV) 01560 return(RNL_ERROR); 01561 01562 lval = (long) uval.f; 01563 *val = lval; 01564 break; 01565 01566 case DT_REAL: 01567 case DT_DBLE: 01568 break; 01569 01570 case DT_LOG: 01571 default: 01572 return(RNL_ERROR); 01573 01574 } /* switch */ 01575 } 01576 01577 return(0); 01578 } 01579 01580 /* 01581 * Read a character string. 01582 * 01583 * Input: inptr will point one past the first character of the string. 01584 * "c" will contain the first character of the string. 01585 * 01586 * Returns: 0 if ok, 01587 * -1 if EOF 01588 * RNL_ERROR if error 01589 */ 01590 01591 static int 01592 g_charstr( 01593 long p, /* Address of variable being read */ 01594 int cnt, /* Number of strings we expect to read */ 01595 char c, /* First character of string. */ 01596 unit *cup, 01597 struct Echoinfo *echoptr, 01598 struct Inpinfo *inptr, 01599 int lcount, /* Repeat count */ 01600 int elsize /* declared size of character item */ 01601 ) 01602 { 01603 int eos; /* eos == -1 if end or beginning of string */ 01604 int i, ch; 01605 unsigned int len77; 01606 char *cp; 01607 long stat; 01608 char enddelim; 01609 char c1; 01610 int repcount; 01611 char *cpold; 01612 int ss; 01613 long *optr; 01614 int ocnt; 01615 _fcd fchp; 01616 01617 /* 01618 * Character data may be enclosed in apostrophes or quotation marks. 01619 * Each apostrophe within a character constant 01620 * delimited by apostrophes must be represented by 01621 * 2 consecutive apostrophes without an intervening blank or 01622 * end of record. The same holds true for quotation marks. Character 01623 * constants may be continued from the end of one record to the 01624 * beginning of the next record. The end of the record does not 01625 * cause a blank or any other character to become part of the constant. 01626 * Blank characters, separator characters, comment characters, and 01627 * delimiter characters may appear in character constants. 01628 * If the character constant has the following properties: 01629 * 1. It does not contain blank characters, 01630 * separator characters, comment characters, left parenthesis 01631 * or delimiter characters. 01632 * 2. It does not cross a record boundary, 01633 * 3. the first nonblank character is not a quotation mark or apostrophe, 01634 * 4. the leading characters are not numeric followed by asterisk, 01635 * 5. the leading characters are not numeric followed by R, H, or L 01636 * then the enclosing apostrophes or quotation marks are not required 01637 * and apostrophes or quotation marks within the character constant 01638 * are not to be doubled. 01639 * 01640 * Let len be the length of the list item, and let w be the length 01641 * of the character constant. If len is less than or equal to w, 01642 * the leftmost len characters of the constant are transmitted to the 01643 * variable. If len is greater than w, the constant is transmitted to 01644 * the leftmost w characters of the variable and the remaining len-w 01645 * characters of the list item are filled with blanks. 01646 */ 01647 01648 eos = 0; 01649 len77 = elsize; /* Get character element length */ 01650 01651 if (len77 != 0) { 01652 01653 /* p is a c pointer to the character data */ 01654 cp = (char *) p; 01655 repcount = MIN(lcount,cnt); 01656 01657 /* 01658 * If the first character is a quote or apostrophe, we expect 01659 * that character to delimit the end of the string. 01660 */ 01661 01662 if ((c == '\'') || (c == '"')) { 01663 enddelim = c; 01664 01665 /* find characters in string */ 01666 01667 for (i = 0; i < len77 && eos == 0; i++) { 01668 GETSTR(); 01669 if (eos == 0) 01670 *cp++ = ch; 01671 } 01672 01673 if (eos == -1) 01674 i--; 01675 01676 i = len77 - i; /* If declared len > read len */ 01677 01678 (void) memset(cp, BLANK, i); /* then blank fill */ 01679 01680 cp = cp + i; 01681 01682 while (eos != -1) { 01683 /* 01684 * We didn't hit the end of the string yet. 01685 * Search for it. 01686 */ 01687 01688 GETSTR(); 01689 } 01690 01691 while (--repcount) { 01692 /* We have a repeat count. 01693 * cp will point to the next element. 01694 * Copy len77 characters to the next 01695 * element. 01696 */ 01697 01698 cpold = (char *) p; 01699 (void) memcpy(cp, cpold, len77); 01700 cp = cp + len77; /* Next element */ 01701 } 01702 01703 } 01704 else { 01705 /* 01706 * We have a character string that's not surrounded 01707 * by quotes (or apostrophes). Read until we see a 01708 * blank, separator, comment, or EOR (which looks 01709 * like a blank to us). Store as many of them as 01710 * we have room for. We cannot have a repeat count 01711 * unless we're surrounded by quotes or apostrophes. 01712 */ 01713 if (lcount > 1) 01714 RNLERROR(FENLNOVL); /* invalid character data */ 01715 01716 /* 01717 * Determine if this is a value or a variable name. 01718 * Save count and pointer in case this isn't a value. 01719 */ 01720 01721 ocnt = inptr->incnt; 01722 optr = inptr->inptr; 01723 c1 = *optr++; 01724 ocnt--; 01725 01726 while (!(ISSPTB(c1))) { 01727 01728 if (MATCH(c1, _MASKS, MRNLSEP) || 01729 MATCH(c1, _MASKS, MRNLDELIM)) 01730 break; /* Assume value */ 01731 01732 if (MATCH(c1, _MASKS, MRNLREP) || c1 == '(' ) { 01733 /* 01734 * Reset, because this MAY have been 01735 * the first letter of a variable name. 01736 */ 01737 inptr->inptr--; 01738 inptr->incnt++; 01739 01740 return(2); /* Null value */ 01741 } 01742 01743 c1 = *optr++; 01744 ocnt--; 01745 } 01746 01747 while ((ISSPTB(c1)) && ocnt-- > 0) 01748 c1 = *optr++; 01749 01750 if (MATCH(c1, _MASKS, MRNLREP) || (c1 == '(')) { 01751 /* 01752 * Reset, because this MAY have been 01753 * the first letter of a variable name. 01754 */ 01755 inptr->inptr--; 01756 inptr->incnt++; 01757 return(2); /* Null value */ 01758 } 01759 01760 i = 0; 01761 c1 = c; 01762 01763 while (!(ISSPTB(c1))) { 01764 01765 if (i < len77) { 01766 *cp++ = c1; 01767 i++; 01768 } 01769 01770 LGET(c1); 01771 01772 if (MATCH(c1, _MASKS, MRNLSEP) || 01773 MATCH(c1, _MASKS, MRNLCOMM)) { 01774 /* Want to read and handle next time */ 01775 inptr->inptr--; 01776 inptr->incnt++; 01777 break; 01778 } 01779 } 01780 01781 /* If declared length > amount read, blank fill */ 01782 01783 i = len77 - i; 01784 (void) memset(cp, BLANK, i); 01785 cp = cp + i; 01786 } 01787 01788 } 01789 else { 01790 RNLERROR(FENLIOER); /* indicate error */ 01791 } 01792 01793 return(0); 01794 } 01795 01796 /* 01797 * Read a hollerith string. 01798 * 01799 * Returns: 0 if a value was found, 01800 * -1 if EOF 01801 * RNLERROR if an error occurred (errno is set) 01802 */ 01803 01804 static int 01805 get_holl( 01806 char holltype, 01807 int count, /* Number of characters in string */ 01808 int type, /* Type of data item */ 01809 unit *cup, 01810 struct Echoinfo *echoptr, 01811 struct Inpinfo *inptr, 01812 long *lval 01813 ) 01814 { 01815 int i; 01816 char *holbufptr; 01817 char c; 01818 long stat; 01819 int ss; 01820 int fill; 01821 /* 01822 * Read 'count' characters from the current word, packing them 01823 * left justified into lval[0]. 01824 * 01825 * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data. 01826 * Hollerith input is supported for compatibility with 01827 * old versions of namelist. 01828 * 01829 * Because we don't allow CHARACTER data, we can make the 01830 * simplifying assumption that we start on a word boundary. 01831 * Also, we are going to assume that whatever we read in will need 01832 * to fit in one word. Repeat counts are allowed. If it becomes 01833 * necessary to allow hollerith strings of > 8 characters, some 01834 * thought will need to be given as to how to handle repeat counts. 01835 */ 01836 01837 if (type == DT_CMPLX || type == DT_DBLE || type == DT_CHAR) 01838 RNLERROR(FENLTYPI); /* Indicate error: type mismatch */ 01839 01840 if (count > sizeof(long)) { 01841 RNLERROR(FENLIOER); /* Indicate error */ 01842 } 01843 01844 fill = BLANK; 01845 holbufptr = (char *)lval; 01846 01847 if (holltype == 'R' || holltype == 'r') { 01848 /* right justified */ 01849 fill = NULLC; 01850 holbufptr = holbufptr + (sizeof(long) - count); 01851 } 01852 else 01853 if (holltype == 'L' || holltype == 'l') 01854 fill = NULLC; 01855 01856 /* 01857 * Last character in buffer is the EOR character, 01858 * that's why we check for incnt > 1 01859 */ 01860 01861 for (i = 0; i < count && (inptr->incnt > 1) ; i++) { 01862 LGET(c); /* use LGET because comment characters are not 01863 * special inside hollerith string */ 01864 *holbufptr++ = c; 01865 } 01866 01867 if (i == count) { 01868 /* Do we need to fill the last word? */ 01869 if (holltype == 'R' || holltype == 'r') /* right justified? */ 01870 holbufptr = (char *)lval; 01871 01872 (void) memset(holbufptr, fill, sizeof(long) - count); 01873 } 01874 else { 01875 /* 01876 * We hit EOR before we read enough characters _or_ we had 01877 * too many characters. 01878 */ 01879 01880 RNLERROR(FENLIOER); 01881 } 01882 01883 return(0); 01884 } 01885 01886 /* 01887 * Get a hollerith string that is surrounded by quotes or apostrophes 01888 * Legal syntax is '----'L, '----'R, or '----'H 01889 * 01890 * Returns: 0 if a value was found, 01891 * -1 if EOF 01892 * RNL_ERROR if an error occurred (errno is set) 01893 */ 01894 01895 static int 01896 get_quoholl( 01897 char cdelim, /* Quote or apostrophe (to end hollerith) */ 01898 int type, /* Type of data */ 01899 unit *cup, 01900 struct Echoinfo *echoptr, 01901 struct Inpinfo *inptr, 01902 long *lval /* Value is placed here */ 01903 ) 01904 { 01905 int numchar; /* character counter */ 01906 int j; 01907 int fill; /* Character to fill with: either ' ' or '\0' */ 01908 long holbuf; /* Data is stored here until we know whether 01909 it is right or left justified. */ 01910 char *holbufptr; /* pointer into holbuf */ 01911 char c; /* Character read */ 01912 long stat; 01913 char *lvalcharptr; /* Pointer to value */ 01914 int ss; 01915 01916 /* 01917 * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data. 01918 * Hollerith input is supported for compatibility with 01919 * old versions of namelist. 01920 * 01921 * Because we don't allow CHARACTER data, we can make the 01922 * simplifying assumption that we start on a word boundary. 01923 * Also, we are going to assume that whatever we read in will need 01924 * to fit in one word. Repeat counts are allowed. If it becomes 01925 * necessary to allow hollerith strings of > 8 characters, some 01926 * thought will need to be given as to how to handle repeat counts. 01927 */ 01928 01929 if (type == DT_CMPLX || type == DT_DBLE || type == DT_CHAR) 01930 RNLERROR(FENLTYPI); 01931 01932 lvalcharptr = (char *)lval; 01933 holbufptr = (char *) &holbuf; 01934 01935 /* 01936 * We do not allow these quoted strings to be continued on 01937 * another record. 01938 */ 01939 01940 numchar = 0; 01941 01942 for (;;) { 01943 01944 LGET(c); 01945 01946 if (c == cdelim) { 01947 01948 /* Comment characters allowed inside quoted string */ 01949 01950 LGET(c); 01951 01952 if (c != cdelim) 01953 break; /* That was the end of the quoted 01954 * string. Otherwise, we saw two 01955 * quotes in a row, which means 01956 * we store one. 01957 */ 01958 } 01959 01960 if (++numchar > sizeof(long)) 01961 RNLERROR(FENLIOER); 01962 01963 *holbufptr++ = c; /* Save the character */ 01964 01965 /* 01966 * Last character in the input buffer is the EOR character, 01967 * that's why we check for incnt <= 1 01968 */ 01969 if (inptr->incnt <= 1) { 01970 RNLERROR(FENLIOER); 01971 } 01972 01973 } /* On exit from this loop, numchar = number of chars. stored */ 01974 01975 01976 if (c == 'L' || c == 'l') 01977 fill = NULLC; 01978 else if (c == 'R' || c == 'r') { 01979 01980 /* Right justify and store the value just read */ 01981 01982 holbufptr = holbufptr - 1; /* Last character */ 01983 lvalcharptr = lvalcharptr + (sizeof(long) - 1); 01984 j = sizeof(long) - numchar; 01985 01986 while (numchar-- > 0) 01987 *lvalcharptr-- = *holbufptr--; 01988 01989 /* Fill word with 0's if necessary */ 01990 01991 while (j-- > 0) 01992 *lvalcharptr-- = '\0'; 01993 01994 return(0); 01995 } 01996 else { 01997 /* H format */ 01998 fill = BLANK; 01999 02000 if (c != 'H' && c != 'h') { 02001 /* Reset pointers, this character does */ 02002 /* not belong to this value */ 02003 inptr->inptr--; 02004 inptr->incnt++; 02005 } 02006 } 02007 02008 /* Do we need to fill the last word? */ 02009 02010 (void) memset(holbufptr, fill, sizeof(long) - numchar); 02011 02012 *lval = holbuf; 02013 02014 return(0); 02015 } 02016 02017 02018 /* 02019 * Octal or hex editing, provided for compatibility with old versions 02020 * of namelist. 02021 * Legal formats: O'123 or O'123'. Octal number may not contain blanks, 02022 * and this is a difference with the old version of namelist. 02023 * Legal formats: Z'1a3 or Z'1a3'. 02024 * 02025 * On input: inptr should point to the character immediately following the O 02026 * 02027 * Returns: 0 if a value was found, 02028 * 1 if a null value was found 02029 * 2 if a null value was found, and it is not followed 02030 * by another value 02031 * -1 if EOF 02032 * RNLERROR if an error occurred (errno is set) 02033 */ 02034 02035 static int 02036 g_octhex( 02037 int type, 02038 unit *cup, 02039 struct Echoinfo *echoptr, 02040 struct Inpinfo *inptr, 02041 long *lval, 02042 int base 02043 ) 02044 { 02045 char c; 02046 long stat; 02047 char strbuf[2]; 02048 int ss; 02049 02050 if (*inptr->inptr != '\'') { 02051 /* Can't be a value, might be a variable name */ 02052 inptr->inptr--; 02053 inptr->incnt++; 02054 02055 return(2); /* NULL value */ 02056 } 02057 02058 /* 02059 * This type of format won't work for complex or double precision 02060 */ 02061 02062 if (type == DT_CMPLX || type == DT_DBLE) { 02063 RNLERROR(FENLTYPI); /* type mismatch */ 02064 } 02065 02066 LGET(c); /* Skip the apostrophe */ 02067 LGET(c); /* and get the next character */ 02068 *lval = 0; 02069 strbuf[1] = '\0'; 02070 02071 while (!(ISSPTB(c)) && c != '\'') { 02072 02073 if (base == OCTAL) { 02074 02075 if ((!isdigit((int) c)) || (c == '9') || 02076 (*lval >> 61)) { 02077 RNLERROR(FENICVIC); /* NICV type error */ 02078 } 02079 02080 *lval = (*lval * 8) + c - '0'; 02081 } 02082 else { /* Check for hex digit or overflow */ 02083 02084 if ((!isxdigit(c)) || (*lval >> 60)) { 02085 RNLERROR(FENICVIC); /* NICV type error */ 02086 } 02087 02088 strbuf[0] = c; 02089 *lval = (*lval * 16) + 02090 (int) strtol(strbuf, (char **)NULL, 16); 02091 } 02092 02093 CMNTLGET(c); /* Check for comments following value */ 02094 02095 if (MATCH(c, _MASKS, MRNLSEP)) { 02096 inptr->inptr--; 02097 inptr->incnt++; /* Want to read separator after */ 02098 break; /* after we return from this routine */ 02099 } 02100 } 02101 02102 return(0); /* indicate value */ 02103 } 02104 02105 02106 /* 02107 * _rnl_fillrec - reads one line from a file. 02108 * 02109 * return value: 0 - normal return 02110 * EOF - end of file 02111 * RNL_ERROR - error was encountered (errno is set) 02112 * cup->uend is set if EOF encountered 02113 */ 02114 02115 static int 02116 _rnl_fillrec( 02117 unit *cup, 02118 struct Echoinfo *echoptr, 02119 struct Inpinfo *inptr 02120 ) 02121 { 02122 long stat; 02123 int ss; 02124 02125 inptr->incnt = _frch(cup, inptr->instart, cup->urecsize, 1, &stat); 02126 02127 if (inptr->incnt < 0 || stat != EOR) { 02128 if (stat == EOF) { 02129 inptr->incnt = 1; /* Treat as if it had 1 blank */ 02130 cup->uend = PHYSICAL_ENDFILE; 02131 return(EOF); 02132 } 02133 else if (stat == EOD) { 02134 inptr->incnt = 1; /* Treat as if it had 1 blank */ 02135 if (cup->uend == 0) 02136 cup->uend = LOGICAL_ENDFILE; 02137 return(EOF); 02138 } 02139 else if (stat == CNT) { 02140 errno = FENLRECL; /* Too much in a record */ 02141 return(RNL_ERROR); 02142 } 02143 02144 if (inptr->incnt < 0) { 02145 return(RNL_ERROR); /* error code already in errno*/ 02146 } 02147 } 02148 02149 cup->uend = 0; 02150 02151 if (inptr->incnt == 0) 02152 inptr->incnt = 1; /* Treat this as if it had 1 blank */ 02153 02154 /* Add a blank character to end of record */ 02155 02156 *(inptr->instart+inptr->incnt) = (long) ' '; 02157 02158 if ((echoptr->rnlecho) || 02159 (MATCH(*inptr->instart, _MASKS, MRNLFLAG))) { 02160 /* Begin echoing input */ 02161 echoptr->rnlecho = 1; 02162 _rnlecho(echoptr->eunit, inptr); 02163 } 02164 02165 /* Always skip the first character in a record.*/ 02166 /* Don't need to adjust incnt because we added a blank at the end. */ 02167 02168 inptr->inptr = inptr->instart + 1; 02169 02170 return(0); 02171 } 02172 02173 static void 02174 pr_msg(char *string) 02175 { 02176 (void) write(fileno(errfile), string, strlen(string)); 02177 02178 return; 02179 } 02180 02181 02182 /* 02183 * Returns: 0 if delimiter is not part of hollerith string 02184 * 1 if delimiter is part of hollerith string 02185 */ 02186 02187 static int 02188 isholl( 02189 long *hlptr, /* Pointer to possible hollerith character */ 02190 struct Inpinfo *inptr 02191 ) 02192 { 02193 char hlval; 02194 02195 hlval = (char) *(hlptr - 1); 02196 02197 if (isdigit(hlval) && ((hlval - '0') <= 8) && ((hlval - '0') > 0)) { 02198 /* 02199 * We have digit followed by Hollerith designator, check 02200 * the preceding character. 02201 */ 02202 if (((hlval - '0') + hlptr) >= (inptr->inptr - 1)) { 02203 02204 /* Column 1 of input is in inbuff[1] and is ignored */ 02205 02206 if (hlptr > &inptr->inbuff[3]) { 02207 02208 hlval = (char) *(hlptr - 2); 02209 02210 if (!ISSPTB(hlval) && hlval != '*' && 02211 !MATCH(hlval, _MASKS, MRNLREP) && 02212 !MATCH(hlval, _MASKS, MRNLSEP) ) 02213 return(0); 02214 } 02215 02216 return(1); 02217 02218 } 02219 02220 return(0); /* Delimiter is beyond Hollerith string */ 02221 02222 } 02223 02224 return(0); 02225 }