|
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 #ifndef _OLD_ERROR_NUMBERS 00039 #pragma ident "@(#) libf/fio/fmtparse.c 92.3 06/18/99 19:52:04" 00040 #endif 00041 #include "lio.h" /* For spiffy IS_DIGIT() macro */ 00042 #include <ctype.h> 00043 #include <stdlib.h> 00044 #include <string.h> 00045 #include <cray/format.h> 00046 #include <cray/nassert.h> 00047 #include <cray/portdefs.h> 00048 00049 typedef struct { 00050 char fmt_ch; /* Current character in format */ 00051 char *fmt_ptr; /* Pointer to current format char. */ 00052 short caller; /* Caller is library or compiler */ 00053 short depth; /* Current format nesting depth */ 00054 short maxdepth; /* Maximum format nesting depth */ 00055 short fatal_err; /* Flag to indicate fatal error */ 00056 long desc_col; /* Pointer to actual edit desc. */ 00057 long fmt_pos; /* Current position in format */ 00058 long fmt_len; /* Number of characters in format */ 00059 fmt_type *parsed; /* Pointer to parsed format block */ 00060 fmt_type *pptr; /* Pointer to current parsed entry */ 00061 fmt_type *revert; /* Pointer to reversion point */ 00062 msg_type *stat; /* Pointer to error status word */ 00063 _Error_function *iss_msg; /* Pointer to format error handler */ 00064 } parse_block; 00065 00066 /* Declare 'forward' functions for type-checking */ 00067 00068 static void 00069 fmterr ( parse_block *pfmt, 00070 short msg_num, 00071 short code, 00072 long column); 00073 00074 static short 00075 process_paren_group ( parse_block *pfmt, 00076 fmt_type *ploc); 00077 00078 /* Table of nonrepeatable characters */ 00079 00080 static int64 non_repeatable[2] = { 00081 0x00000000297EFFE0, /* " $ ' ) * + , - . 0-9 : */ 00082 0x0000180800001800 /* S T \ s t */ 00083 }; 00084 00085 /* 00086 * Macros to return next character and gather up a number. 00087 * At start, fmt_ptr needs to be incremented. At end, 00088 * fmt_ptr points to the returned character. Input is 00089 * a Fortran character string, so EOS is not always '\0'. 00090 */ 00091 00092 #define GET(P) { \ 00093 do { \ 00094 if (++P->fmt_pos > P->fmt_len) { \ 00095 P->fmt_ch = '\0'; \ 00096 P->fmt_pos--; \ 00097 break; \ 00098 } \ 00099 P->fmt_ch = *(++P->fmt_ptr); \ 00100 } while (P->fmt_ch == ' ' || P->fmt_ch == '\t'); \ 00101 } 00102 00103 #define GETNUM(P, M) { \ 00104 do { \ 00105 M = (M + M + (M << 3)) + ((int64) P->fmt_ch - ZERO);\ 00106 GET(P); \ 00107 } while (IS_DIGIT(P->fmt_ch)); \ 00108 } 00109 00110 /* Bridge for symbol renaming */ 00111 00112 #ifndef E_WITH_D_NON_ANSI 00113 #define E_WITH_D_NON_ANSI DW_IS_NON_ANSI 00114 #endif 00115 00116 /* 00117 * _fmt_parse() 00118 * 00119 * Description: This routine initializes variables for the format 00120 * parser, positions the input to the first character, 00121 * calls the actual format parser and cleans up. 00122 * 00123 * Called By: cft77, cft90 and the I/O library. 00124 * 00125 * Calls: process_paren_group 00126 * calloc 00127 * realloc 00128 * fmterr 00129 * 00130 * Input parameters: 00131 * msg_rtn Pointer to a pointer to the message routine to 00132 * be called if this is a compiler call. NULL if 00133 * this is a library call. 00134 * format_str Pointer to the format string to be parsed. 00135 * routine_caller Library/compiler flag. 00136 * 00137 * Output parameters: 00138 * fmt_str_len The length in words of the parsed format. 00139 * msg_out_ptr Pointer to the list of messages found. 00140 * 00141 * Returns: A pointer to the parsed format string. The first 00142 * two-word entry of the parsed format is for control 00143 * information; the first word is reserved for use by 00144 * the compiler, the second word is reserved for use 00145 * by the parser and library. 00146 * 00147 * Note: The input parameters are pointers to interface with 00148 * Pascal. 00149 */ 00150 00151 fmt_type * 00152 _fmt_parse( 00153 _Error_function **msg_rtn, 00154 char *format_str, 00155 long routine_caller, 00156 long *fmt_str_len, 00157 msg_type *lib_err_msg 00158 ) 00159 { 00160 register short length; 00161 parse_block *pfmt, p; 00162 00163 /* Basic assertions */ 00164 00165 assert (format_str != NULL); 00166 assert (routine_caller >= 0 && routine_caller <= MAX_CALL_FLAG); 00167 assert (fmt_str_len != NULL); 00168 assert (*fmt_str_len > 0); 00169 assert (routine_caller == LIB_CALL ? lib_err_msg != NULL : 1); 00170 assert (routine_caller != LIB_CALL ? msg_rtn != NULL : 1); 00171 00172 /* 00173 * If this routine is called from the library (routine_caller = 00174 * LIB_CALL) then the parser returns the number and position of the 00175 * first fatal error found--if any--and then exits. Any other caller 00176 * (e.g., compilers) must provide their own error routine by passing 00177 * a pointer to the routine in the first argument. The parser will 00178 * continue parsing until the end of the format is reached. 00179 */ 00180 00181 pfmt = &p; 00182 00183 pfmt->fmt_pos = 0; 00184 pfmt->depth = 0; 00185 pfmt->maxdepth = 0; 00186 pfmt->fatal_err = FALSE; 00187 pfmt->iss_msg = (msg_rtn == NULL ? NULL : *msg_rtn); 00188 pfmt->stat = lib_err_msg; 00189 pfmt->fmt_ptr = format_str - 1; /* Set for first GET call */ 00190 pfmt->fmt_len = *fmt_str_len; 00191 pfmt->caller = routine_caller; 00192 00193 GET(pfmt); 00194 00195 pfmt->desc_col = pfmt->fmt_pos; 00196 00197 if (pfmt->fmt_ch == '(') { 00198 GET(pfmt); 00199 } 00200 else { 00201 fmterr(pfmt, EXPECTING_LEFT_PAREN, FALL, 0); 00202 00203 /* Library quits at first fatal error */ 00204 00205 if (pfmt->caller == LIB_CALL) 00206 return( (fmt_type *) NULL); 00207 } 00208 00209 /* 00210 * We need to allocate a parsed format structure with enough 00211 * entries to accommodate this format (we'll free any unused 00212 * entries when we're done). Our initial guess is the number 00213 * of characters in the format plus two (one for the header and 00214 * one for the REVERT_OP entry). Note that for a long, sparse 00215 * format (with lots of blanks), this will allocate way too 00216 * much space. 00217 */ 00218 00219 pfmt->parsed = (fmt_type *) calloc(pfmt->fmt_len + 2, 00220 sizeof(fmt_type)); 00221 00222 if (pfmt->parsed == NULL) { 00223 00224 fmterr(pfmt, UNABLE_TO_MALLOC_MEMORY, FALL, 0); 00225 00226 /* No place for format, so quit */ 00227 00228 return( (fmt_type *) NULL); 00229 } 00230 00231 pfmt->pptr = pfmt->parsed + 1; 00232 pfmt->revert = pfmt->pptr; 00233 00234 /* Parse the format string */ 00235 00236 (void) process_paren_group(pfmt, pfmt->pptr); 00237 00238 if (pfmt->fatal_err) { 00239 free( (char *) pfmt->parsed); /* Return memory */ 00240 pfmt->parsed = NULL; 00241 length = 0; 00242 } 00243 else { 00244 length = pfmt->pptr - pfmt->parsed; 00245 pfmt->parsed->offset = PARSER_LEVEL; 00246 pfmt->parsed->rep_count = pfmt->maxdepth + 1; 00247 00248 if (pfmt->fmt_ch != '\0') 00249 fmterr(pfmt, TRAILING_CHARS, FALL, 0); 00250 00251 if (pfmt->caller == LIB_CALL) 00252 pfmt->parsed = (fmt_type *) realloc ( 00253 (char *) pfmt->parsed, 00254 length * FMT_ENTRY_BYTE_SIZE ); 00255 } 00256 00257 *fmt_str_len = length * FMT_ENTRY_WORD_SIZE; 00258 00259 return(pfmt->parsed); 00260 00261 } /* _parsfmt */ 00262 00263 /* 00264 * fmterr() 00265 * 00266 * Description: This routine processes errors encountered while 00267 * parsing formats. 00268 * 00269 * Called By: All routines in this file. 00270 * 00271 * Input parameters: 00272 * pfmt Parsing information block 00273 * msg_num Message number (see format.h) 00274 * code Compiler applicability code 00275 * FALL Error/warning applies to all compilers 00276 * F77 Error/warning applies only to f77 00277 * F90 Error/warning applies only to f90 00278 * F95 Error/warning applies only to f95 00279 * column Column number corresponding to error. If 00280 * zero, use current position. 00281 * 00282 * Returns: Nothing 00283 * 00284 * Note: Two column pointers are passed to the error processing 00285 * routine. The first points to the position in the 00286 * format where the actual error occurred; the second 00287 * points to the edit descriptor being processed. 00288 */ 00289 00290 static void 00291 fmterr( 00292 parse_block *pfmt, 00293 short msg_num, 00294 short code, 00295 long column 00296 ) 00297 { 00298 register short callflg; 00299 00300 callflg = 0; /* Assume no call to error function */ 00301 00302 if (msg_num >= FIRST_FATAL_MESSAGE) 00303 pfmt->fatal_err = TRUE; 00304 00305 if (column == 0) 00306 column = pfmt->fmt_pos; 00307 00308 switch (pfmt->caller) { 00309 00310 case LIB_CALL: 00311 00312 /* Ignore warnings and non-ANSI messages */ 00313 00314 if (msg_num >= FIRST_FATAL_MESSAGE) { 00315 pfmt->stat->msg_number = msg_num; 00316 pfmt->stat->msg_column = column; 00317 pfmt->stat->desc_column = pfmt->desc_col; 00318 } 00319 break; 00320 00321 case COMPILER_CALL_NO_ANSI: 00322 00323 /* Ignore ANSI messages */ 00324 00325 callflg = (msg_num < FIRST_NON_ANSI_MESSAGE || 00326 msg_num >= FIRST_FATAL_MESSAGE); 00327 break; 00328 00329 case COMPILER_CALL_ANSI: 00330 00331 /* Call compiler error routine */ 00332 00333 callflg = 1; 00334 break; 00335 00336 case COMPILER_CALL_ANSI_77: 00337 00338 /* Ignore any non-f77 messages */ 00339 00340 callflg = (code & F77); 00341 break; 00342 00343 case COMPILER_CALL_ANSI_90: 00344 00345 /* Ignore any non-f90 messages */ 00346 00347 callflg = (code & F90); 00348 break; 00349 00350 case COMPILER_CALL_ANSI_95: 00351 00352 /* Ignore any non-f95 messages */ 00353 00354 callflg = (code & F95); 00355 break; 00356 } /* switch */ 00357 00358 if (callflg != 0) 00359 (*pfmt->iss_msg) (msg_num, column, pfmt->desc_col); 00360 00361 return; 00362 00363 } /* fmterr */ 00364 00365 /* 00366 * recover() 00367 * 00368 * Description: This routine tries to recover from a fatal error by 00369 * searching for the character: ',', ')', '(', '"', '*', 00370 * "'", or EOF after the error. This should position 00371 * the parser at a valid format descriptor. 00372 * 00373 * Called By: process_paren_group 00374 * process_defg 00375 * process_bioz 00376 * process_arl 00377 * process_minus 00378 * 00379 * Input parameters: 00380 * pfmt Parsing information block 00381 * 00382 * Returns: Nothing 00383 */ 00384 00385 static void 00386 recover( 00387 parse_block *pfmt 00388 ) 00389 { 00390 register short found_char; 00391 00392 found_char = FALSE; 00393 00394 if (pfmt->caller != LIB_CALL) 00395 do { 00396 switch (pfmt->fmt_ch) { 00397 case ',': 00398 case ')': 00399 case '(': 00400 case '"': 00401 case '*': 00402 case '\'': 00403 case '\0': 00404 found_char = TRUE; 00405 break; 00406 00407 default: 00408 GET(pfmt); 00409 break; 00410 } /* switch */ 00411 } while (!found_char); 00412 00413 return; 00414 00415 } /* recover */ 00416 00417 /* 00418 * nonzero_integer() 00419 * 00420 * Description: This routine finds and returns a nonzero integer 00421 * or issues an error. 00422 * 00423 * Called By: process_t 00424 * 00425 * Calls: fmterr 00426 * 00427 * Input parameters: 00428 * pfmt Parsing information block 00429 * 00430 * Output parameters: 00431 * size The nonzero integer. 00432 * 00433 * Returns: TRUE if a nonzero integer is found, else FALSE. 00434 */ 00435 00436 static short 00437 nonzero_integer( 00438 parse_block *pfmt, 00439 long *size 00440 ) 00441 { 00442 register short return_val; 00443 register int64 value; 00444 register long col; 00445 00446 if (IS_DIGIT(pfmt->fmt_ch)) { 00447 00448 col = pfmt->fmt_pos; 00449 return_val = TRUE; 00450 value = *size; 00451 00452 GETNUM(pfmt, value); 00453 00454 if (value == 0) { 00455 fmterr(pfmt, FIELD_WIDTH_ZERO, FALL, col); 00456 value = 1; 00457 } 00458 else 00459 if (value > MAX_FIELD_WIDTH) { 00460 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00461 value = MAX_FIELD_WIDTH; 00462 } 00463 } 00464 else { 00465 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00466 return_val = FALSE; 00467 value = 1; 00468 } 00469 00470 *size = value; /* Update value */ 00471 00472 return(return_val); 00473 00474 } /* nonzero_integer */ 00475 00476 /* 00477 * process_arl() 00478 * 00479 * Description: This does semantic checking and generates text for 00480 * the A, L and R data edit-descriptors. 00481 * 00482 * Called By: process_paren_group 00483 * 00484 * Calls: fmterr 00485 * 00486 * Input parameters: 00487 * pfmt Parsing information block 00488 * op_code Is it A, L or R? 00489 * 00490 * Valid forms: 00491 * A 00492 * Aw 00493 * L (MIPSpro extension) 00494 * Lw 00495 * R (MIPSpro extension) 00496 * Rw 00497 * 00498 * Returns: Nothing 00499 */ 00500 00501 static void 00502 process_arl( 00503 parse_block *pfmt, 00504 unsigned short op_code 00505 ) 00506 { 00507 register long col; 00508 register int64 size; 00509 00510 size = 0; 00511 00512 GET(pfmt); 00513 00514 if (IS_DIGIT(pfmt->fmt_ch)) { 00515 00516 col = pfmt->fmt_pos; 00517 00518 GETNUM(pfmt, size); 00519 00520 if (size == 0) { 00521 #ifdef _OLD_ERROR_NUMBERS 00522 fmterr(pfmt, FIELD_WIDTH_ZERO, FALL, col); 00523 size = 1; 00524 #else 00525 fmterr(pfmt, ZERO_WIDTH_NON_ANSI, FALL, col); 00526 #endif 00527 } 00528 else 00529 if (size > MAX_FIELD_WIDTH) { 00530 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00531 size = MAX_FIELD_WIDTH; 00532 } 00533 } 00534 else 00535 if (op_code != A_ED) { 00536 #ifdef _OLD_ERROR_NUMBERS 00537 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00538 recover(pfmt); 00539 #else 00540 fmterr(pfmt, MISSING_WIDTH_NON_ANSI, FALL, pfmt->fmt_pos); 00541 #endif 00542 } 00543 00544 pfmt->pptr->op_code = op_code; 00545 pfmt->pptr->field_width = size; 00546 pfmt->pptr = pfmt->pptr + 1; 00547 00548 return; 00549 00550 } /* process_arl */ 00551 00552 /* 00553 * process_defg() 00554 * 00555 * Description: This does semantic checking and generates text for 00556 * the D, E, EN, ES, F, and G data edit-descriptors. 00557 * 00558 * Called By: process_paren_group 00559 * 00560 * Calls: fmterr 00561 * 00562 * Input parameters: 00563 * pfmt Parsing information block 00564 * op_code Is it D, E, EN, ES, F or G? 00565 * 00566 * Valid forms: 00567 * D (MIPSpro extension) 00568 * Dw.d 00569 * Dw.dEe (Cray extension) 00570 * E (MIPSpro extension) 00571 * Ew.d 00572 * Ew.dEe 00573 * EN (f90 or later, MIPSpro-style extension) 00574 * ENw.d (f90 or later) 00575 * ENw.dEe (f90 or later) 00576 * ES (f90 or later, MIPSpro-style extension) 00577 * ESw.d (f90 or later) 00578 * ESw.dEe (f90 or later) 00579 * F (MIPSpro extension) 00580 * Fw.d (w can be zero in f95 or later) 00581 * G (MIPSpro extension) 00582 * Gw.d 00583 * Gw.dEe 00584 * 00585 * Returns: Nothing 00586 */ 00587 00588 static void 00589 process_defg( 00590 parse_block *pfmt, 00591 unsigned short op_code 00592 ) 00593 { 00594 register short dset; 00595 register long col; 00596 register int64 esize; 00597 register int64 dsize; 00598 register int64 wsize; 00599 00600 dset = 1; 00601 dsize = 0; 00602 esize = 0; 00603 wsize = 0; 00604 00605 GET(pfmt); 00606 00607 if (IS_DIGIT(pfmt->fmt_ch)) { 00608 00609 col = pfmt->fmt_pos; 00610 00611 GETNUM(pfmt, wsize); 00612 00613 if (wsize == 0) { 00614 #ifdef _OLD_ERROR_NUMBERS 00615 fmterr(pfmt, FIELD_WIDTH_ZERO, FALL, col); 00616 wsize = 1; 00617 #else 00618 register short code; 00619 00620 code = (op_code == F_ED) ? (F77 | F90) : FALL; 00621 00622 fmterr(pfmt, ZERO_WIDTH_NON_ANSI, code, col); 00623 #endif 00624 } 00625 else 00626 if (wsize > MAX_FIELD_WIDTH) { 00627 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00628 wsize = MAX_FIELD_WIDTH; 00629 } 00630 00631 if (pfmt->fmt_ch == '.') { 00632 00633 GET(pfmt); 00634 00635 if (IS_DIGIT(pfmt->fmt_ch)) { 00636 00637 col = pfmt->fmt_pos; 00638 dset = 0; 00639 dsize = 0; 00640 00641 GETNUM(pfmt, dsize); 00642 00643 if (dsize > MAX_DECIMAL_FIELD) { 00644 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00645 dsize = MAX_DECIMAL_FIELD; 00646 } 00647 00648 if (toupper(pfmt->fmt_ch) == 'E' && 00649 op_code != F_ED) { 00650 register long col_e; 00651 00652 col_e = pfmt->fmt_pos; /* Position of 'E' */ 00653 00654 GET(pfmt); 00655 00656 if (IS_DIGIT(pfmt->fmt_ch)) { 00657 00658 col = pfmt->fmt_pos; 00659 00660 GETNUM(pfmt, esize); 00661 00662 if (esize == 0) { 00663 fmterr(pfmt, 00664 FIELD_WIDTH_ZERO, 00665 FALL, 00666 col); 00667 esize = 1; 00668 } 00669 else 00670 if (esize > MAX_EXPONENT) { 00671 fmterr(pfmt, 00672 FIELD_TOO_LARGE, 00673 FALL, col); 00674 esize = MAX_EXPONENT; 00675 } 00676 00677 if (op_code == D_ED) 00678 fmterr(pfmt, E_WITH_D_NON_ANSI, 00679 FALL, col_e); 00680 } 00681 else { 00682 fmterr(pfmt, EXPECTING_INTEGER, 00683 FALL, 0); 00684 recover(pfmt); 00685 } 00686 } 00687 } 00688 else { 00689 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00690 recover(pfmt); 00691 } 00692 } 00693 else { 00694 fmterr(pfmt, EXPECTING_PERIOD, FALL, 0); 00695 recover(pfmt); 00696 } 00697 } 00698 else { 00699 #ifdef _OLD_ERROR_NUMBERS 00700 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00701 recover(pfmt); 00702 #else 00703 fmterr(pfmt, MISSING_WIDTH_NON_ANSI, FALL, pfmt->fmt_pos); 00704 #endif 00705 } 00706 00707 pfmt->pptr->op_code = op_code; 00708 pfmt->pptr->exponent = esize; 00709 pfmt->pptr->field_width = wsize; 00710 pfmt->pptr->digits_field = dsize; 00711 pfmt->pptr->default_digits = dset; 00712 pfmt->pptr = pfmt->pptr + 1; 00713 00714 return; 00715 00716 } /* process_defg */ 00717 00718 /* 00719 * process_bioz() 00720 * 00721 * Description: This does semantic checking and generates text for 00722 * the B, I, O, and Z data edit-descriptors. 00723 * 00724 * Called By: process_paren_group 00725 * 00726 * Calls: fmterr 00727 * 00728 * Input parameters: 00729 * pfmt Parsing information block 00730 * op_code Is it B, I, O or Z? 00731 * 00732 * Valid forms: 00733 * B (MIPSpro extension) 00734 * Bw (w can be zero in f95 or later) 00735 * Bw.m (w can be zero in f95 or later) 00736 * I (MIPSpro extension) 00737 * Iw (w can be zero in f95 or later) 00738 * Iw.m (w can be zero in f95 or later) 00739 * O (MIPSpro extension) 00740 * Ow (w can be zero in f95 or later) 00741 * Ow.m (w can be zero in f95 or later) 00742 * Z (MIPSpro extension) 00743 * Zw (w can be zero in f95 or later) 00744 * Zw.m (w can be zero in f95 or later) 00745 * 00746 * Returns: Nothing 00747 */ 00748 00749 static void 00750 process_bioz( 00751 parse_block *pfmt, 00752 unsigned short op_code 00753 ) 00754 { 00755 register short dset; 00756 register long col; 00757 register int64 dsize; 00758 register int64 wsize; 00759 00760 dset = 1; 00761 dsize = 1; 00762 wsize = 0; 00763 00764 GET(pfmt); 00765 00766 if (IS_DIGIT(pfmt->fmt_ch)) { 00767 00768 col = pfmt->fmt_pos; 00769 00770 GETNUM(pfmt, wsize); 00771 00772 if (wsize == 0) { 00773 #ifdef _OLD_ERROR_NUMBERS 00774 fmterr(pfmt, FIELD_WIDTH_ZERO, FALL, col); 00775 wsize = 1; 00776 #else 00777 fmterr(pfmt, ZERO_WIDTH_NON_ANSI, (F77 | F90), col); 00778 #endif 00779 } else 00780 if (wsize > MAX_FIELD_WIDTH) { 00781 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00782 wsize = MAX_FIELD_WIDTH; 00783 } 00784 00785 if (pfmt->fmt_ch == '.') { 00786 00787 GET(pfmt); 00788 00789 if (IS_DIGIT(pfmt->fmt_ch)) { 00790 00791 col = pfmt->fmt_pos; 00792 dsize = 0; 00793 dset = 0; 00794 00795 GETNUM(pfmt, dsize); 00796 00797 if (dsize > MAX_DECIMAL_FIELD) { 00798 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col); 00799 dsize = MAX_DECIMAL_FIELD; 00800 } 00801 } 00802 else { 00803 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00804 recover(pfmt); 00805 } 00806 } 00807 } 00808 else { 00809 #ifdef _OLD_ERROR_NUMBERS 00810 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 00811 recover(pfmt); 00812 #else 00813 fmterr(pfmt, MISSING_WIDTH_NON_ANSI, FALL, pfmt->fmt_pos); 00814 #endif 00815 } 00816 00817 pfmt->pptr->op_code = op_code; 00818 pfmt->pptr->field_width = wsize; 00819 pfmt->pptr->digits_field = dsize; 00820 pfmt->pptr->default_digits = dset; 00821 pfmt->pptr = pfmt->pptr + 1; 00822 00823 return; 00824 00825 } /* process_bioz */ 00826 00827 /* 00828 * process_t() 00829 * 00830 * Description: This does semantic checking and generates text for 00831 * the Tw, TLw and TRw edit-descriptors. 00832 * 00833 * Called By: process_paren_group 00834 * 00835 * Calls: nonzero_integer 00836 * 00837 * Input parameters: 00838 * pfmt Parsing information block 00839 * 00840 * Returns: Nothing 00841 */ 00842 00843 static void 00844 process_t( 00845 parse_block *pfmt 00846 ) 00847 { 00848 long size; 00849 register char ch; 00850 00851 size = 0; 00852 00853 GET(pfmt); 00854 00855 ch = toupper(pfmt->fmt_ch); 00856 00857 if (ch == 'R') { 00858 00859 GET(pfmt); 00860 00861 if (nonzero_integer(pfmt, &size)) { 00862 pfmt->pptr->op_code = TR_ED; 00863 pfmt->pptr->field_width = size; 00864 pfmt->pptr = pfmt->pptr + 1; 00865 } 00866 } 00867 else 00868 if (ch == 'L') { 00869 00870 GET(pfmt); 00871 00872 if (nonzero_integer(pfmt, &size)) { 00873 pfmt->pptr->op_code = TL_ED; 00874 pfmt->pptr->field_width = size; 00875 pfmt->pptr = pfmt->pptr + 1; 00876 } 00877 } 00878 else 00879 if (nonzero_integer(pfmt, &size)) { 00880 pfmt->pptr->op_code = T_ED; 00881 pfmt->pptr->field_width = size; 00882 pfmt->pptr->rep_count = 1; 00883 pfmt->pptr = pfmt->pptr + 1; 00884 } 00885 00886 return; 00887 00888 } /* process_t */ 00889 00890 /* 00891 * process_p() 00892 * 00893 * Description: This does semantic checking and generates text for 00894 * the P edit-descriptor. It also checks for the ANSI 00895 * comma requirement. 00896 * 00897 * Called By: process_paren_group 00898 * process_minus 00899 * 00900 * Calls: fmterr 00901 * 00902 * Input parameters: 00903 * pfmt Parsing information block 00904 * scale_factor The P edit-descriptor scale factor. Because 00905 * the scale_factor is a signed quantity, it is 00906 * stored in the rep_count field. 00907 * 00908 * Returns: Nothing 00909 */ 00910 00911 static void 00912 process_p( 00913 parse_block *pfmt, 00914 long scale_factor 00915 ) 00916 { 00917 pfmt->pptr->op_code = P_ED; 00918 pfmt->pptr->offset = pfmt->fmt_pos; 00919 pfmt->pptr->rep_count = scale_factor; 00920 pfmt->pptr = pfmt->pptr + 1; 00921 00922 GET(pfmt); 00923 00924 switch (pfmt->fmt_ch) { 00925 case ',': 00926 case 'D': 00927 case 'E': 00928 case 'F': 00929 case 'G': 00930 case 'd': 00931 case 'e': 00932 case 'f': 00933 case 'g': 00934 case ')': 00935 case ':': 00936 case '/': 00937 case '\0': 00938 break; /* Do Nothing */ 00939 00940 default: 00941 fmterr(pfmt, ANSI_COMMA_REQ, FALL, 0); 00942 break; 00943 } /* switch */ 00944 00945 return; 00946 00947 } /* process_p */ 00948 00949 /* 00950 * process_char_string() 00951 * 00952 * Description: This does semantic checking of and moves the 00953 * character string to the intermediate text. 00954 * 00955 * Called By: process_paren_group 00956 * 00957 * Calls: fmterr 00958 * 00959 * Input parameters: 00960 * pfmt Parsing information block 00961 * 00962 * Returns: Nothing 00963 */ 00964 00965 static void 00966 process_char_string( 00967 parse_block *pfmt 00968 ) 00969 { 00970 char *str_ptr; 00971 register long size; 00972 00973 size = 0; 00974 str_ptr = (char *) (pfmt->pptr + 1); 00975 00976 for ( ; ; ) { 00977 00978 if (++pfmt->fmt_pos > pfmt->fmt_len) { 00979 pfmt->fmt_pos = pfmt->fmt_pos - 1; 00980 pfmt->fmt_ch = '\0'; 00981 fmterr(pfmt, NONTERMINATED_LITERAL, FALL, 0); 00982 break; 00983 } 00984 00985 if (*(++pfmt->fmt_ptr) == pfmt->fmt_ch) { 00986 00987 if (pfmt->fmt_pos == pfmt->fmt_len) { 00988 pfmt->fmt_ch = '\0'; 00989 break; 00990 } 00991 00992 if (*(pfmt->fmt_ptr+1) != pfmt->fmt_ch) { 00993 GET(pfmt); 00994 break; 00995 } 00996 else { 00997 pfmt->fmt_pos = pfmt->fmt_pos + 1; 00998 pfmt->fmt_ptr = pfmt->fmt_ptr + 1; 00999 } 01000 } 01001 01002 *str_ptr++ = *pfmt->fmt_ptr; 01003 size = size + 1; 01004 } /* for */ 01005 01006 pfmt->pptr->op_code = STRING_ED; 01007 pfmt->pptr->field_width = size; 01008 pfmt->pptr = pfmt->pptr + 01009 ((size + FMT_ENTRY_BYTE_SIZE - 1) / FMT_ENTRY_BYTE_SIZE) + 1; 01010 01011 return; 01012 01013 } /* process_char_string */ 01014 01015 /* 01016 * process_minus() 01017 * 01018 * Description: This does semantic checking for the use of the '-' 01019 * in a format string. 01020 * 01021 * Called By: process_paren_group 01022 * 01023 * Calls: fmterr 01024 * process_p 01025 * 01026 * Input parameters: 01027 * pfmt Parsing information block 01028 * 01029 * Returns: FALSE if +/-P, because a comma is not required by 01030 * the P edit-descriptor; TRUE otherwise, because a 01031 * comma is required. 01032 */ 01033 01034 static short 01035 process_minus( 01036 parse_block *pfmt 01037 ) 01038 { 01039 register short return_val; 01040 register long col_m; 01041 register long col_n; 01042 01043 return_val = TRUE; /* Assume TRUE */ 01044 col_m = pfmt->fmt_pos; /* Position of '-' */ 01045 01046 GET(pfmt); 01047 01048 col_n = pfmt->fmt_pos; /* Position of token after '-' */ 01049 01050 if (IS_DIGIT(pfmt->fmt_ch)) { 01051 register int64 size; 01052 register char ch; 01053 01054 size = 0; 01055 01056 GETNUM(pfmt, size); 01057 01058 ch = toupper(pfmt->fmt_ch); 01059 01060 if (ch == 'P') { 01061 01062 pfmt->desc_col = pfmt->fmt_pos; 01063 return_val = FALSE; 01064 01065 if (size > MAX_REP_COUNT) { 01066 fmterr(pfmt, FIELD_TOO_LARGE, FALL, col_n); 01067 size = MAX_REP_COUNT; 01068 } 01069 01070 process_p(pfmt, (long) -size); 01071 } 01072 else 01073 if (ch == 'X') { 01074 01075 pfmt->desc_col = pfmt->fmt_pos; 01076 01077 fmterr(pfmt, MINUS_X_NON_ANSI, FALL, col_m); 01078 01079 if (size == 0) { 01080 fmterr(pfmt, FIELD_WIDTH_ZERO, FALL, 01081 col_n); 01082 size = 1; 01083 } 01084 else 01085 if (size > MAX_FIELD_WIDTH) { 01086 fmterr(pfmt, FIELD_TOO_LARGE, 01087 FALL, col_n); 01088 size = MAX_FIELD_WIDTH; 01089 } 01090 01091 pfmt->pptr->op_code = TL_ED; 01092 pfmt->pptr->offset = pfmt->fmt_pos; 01093 pfmt->pptr->field_width = size; 01094 pfmt->pptr = pfmt->pptr + 1; 01095 01096 GET(pfmt); 01097 } 01098 else { 01099 fmterr(pfmt, EXPECTING_P_OR_X, FALL, col_n); 01100 recover(pfmt); 01101 } 01102 } 01103 else { 01104 fmterr(pfmt, EXPECTING_INTEGER, FALL, col_n); 01105 recover(pfmt); 01106 } 01107 01108 return(return_val); 01109 01110 } /* process_minus */ 01111 01112 /* 01113 * process_paren_group() 01114 * 01115 * Description: This is a recursive routine that processes a 01116 * parentheses group and all edit-descriptors in 01117 * that group. Whenever an open parenthesis is 01118 * found (which is not immediately followed by a 01119 * close parenthesis), this routine calls itself. 01120 * It does semantic checking, ANSI checking, creates 01121 * a parsed output that is directly usable by the 01122 * run-time I/O libraries. It also performs the 01123 * following optimizations: 01124 * 01125 * 1) Discards empty parentheses groups, 01126 * 2) Combines edit-descriptors that are alike, such 01127 * as: X becomes TR, -X becomes TL, and Hollerith 01128 * and character strings become STRING, 01129 * 3) Changes things like 6(4a3) to 24a3. 01130 * 01131 * Called By: process_paren_group 01132 * _parsfmt 01133 * 01134 * Calls: fmterr 01135 * process_arl 01136 * process_bioz 01137 * process_char_string 01138 * process_defg 01139 * process_minus 01140 * process_p 01141 * process_t 01142 * 01143 * Input parameters: 01144 * pfmt Parsing information block 01145 * ploc The location of the current open parenthesis 01146 * in the parsed format. 01147 * 01148 * Returns: The number of edit-descriptors encountered. If at 01149 * least one of the edit-descriptors was a data edit- 01150 * descriptor, then the number of edit-descriptors is 01151 * negated. 01152 */ 01153 01154 static short 01155 process_paren_group( 01156 parse_block *pfmt, 01157 fmt_type *ploc 01158 ) 01159 { 01160 register short comma_req_flag; 01161 register short data_ed; 01162 register short found_rep_count; 01163 register short outer_paren; 01164 register short num_eds; 01165 register short op_code; 01166 register short temp; 01167 register long num_start; 01168 register long old_pos; 01169 register int64 repeat_count; 01170 register char ch; 01171 char *old_ptr; 01172 01173 num_eds = 0; 01174 data_ed = FALSE; 01175 outer_paren = (pfmt->pptr == ploc); 01176 01177 do { /* for each item in the parentheses group */ 01178 01179 num_start = pfmt->fmt_pos; 01180 pfmt->desc_col = pfmt->fmt_pos; 01181 comma_req_flag = TRUE; 01182 num_eds = num_eds + 1; /* Assume an edit-descriptor */ 01183 01184 if (IS_DIGIT(pfmt->fmt_ch)) { 01185 register short j, k; 01186 01187 repeat_count = 0; 01188 found_rep_count = TRUE; 01189 01190 GETNUM(pfmt, repeat_count); 01191 01192 pfmt->desc_col = pfmt->fmt_pos; 01193 01194 /* Check if nonrepeatable edit-descriptor */ 01195 01196 j = (((short) pfmt->fmt_ch) >> 6) & 1; 01197 k = ((short) pfmt->fmt_ch) & 077; 01198 01199 if ((non_repeatable[j] << k) < 0) 01200 fmterr(pfmt, INVALID_REP_COUNT, FALL, num_start); 01201 else { /* 0P is valid */ 01202 01203 ch = toupper(pfmt->fmt_ch); 01204 01205 if (repeat_count == 0 && ch != 'P') { 01206 01207 if (ch == 'H') 01208 fmterr(pfmt, 01209 ZERO_OR_NO_HOLLERITH_CNT, 01210 FALL, num_start); 01211 01212 /* 01213 * Do not issue message for B here 01214 * because it may be a BN or BZ edit- 01215 * descriptor. The INVALID_REP_COUNT 01216 * error will be issued, if necessary, 01217 * when the B edit-descriptor is 01218 * processed. 01219 */ 01220 01221 else 01222 if (ch != 'B') 01223 fmterr(pfmt, 01224 ZERO_REP_COUNT, 01225 FALL, num_start); 01226 } 01227 01228 /* 01229 * Ensure that the repeat count hasn't overflowed. We 01230 * skip this check for the H, X and / edit-descriptors 01231 * since they use the repeat count as the field width 01232 * and will check it against a different limit. 01233 */ 01234 01235 if (repeat_count > MAX_REP_COUNT) 01236 if (ch != 'X' && ch != 'H' && ch != '/') { 01237 fmterr(pfmt, FIELD_TOO_LARGE, 01238 FALL, num_start); 01239 repeat_count = MAX_REP_COUNT; 01240 } 01241 } 01242 } 01243 else { /* not a digit */ 01244 repeat_count = 1; 01245 found_rep_count = FALSE; 01246 } 01247 01248 pfmt->pptr->offset = pfmt->fmt_pos; 01249 pfmt->pptr->rep_count = repeat_count; 01250 01251 switch (toupper(pfmt->fmt_ch)) { 01252 01253 case '(': /* Start of parentheses group */ 01254 01255 num_eds = num_eds - 1; 01256 pfmt->pptr->op_code = REPEAT_OP; 01257 pfmt->pptr = pfmt->pptr + 1; 01258 pfmt->depth = pfmt->depth + 1; 01259 01260 /* 01261 * If level one parentheses group, then 01262 * it's a possible reversion point. 01263 */ 01264 01265 if (pfmt->depth == 1) 01266 data_ed = FALSE; 01267 01268 GET(pfmt); 01269 01270 /* 01271 * process_paren_group() is called 01272 * recursively and returns the number 01273 * of edit-descriptors found in the 01274 * parentheses group. The negative 01275 * count of edit-descriptors is 01276 * returned if at least one of them 01277 * is a data edit-descriptor. 01278 */ 01279 01280 temp = process_paren_group(pfmt, 01281 pfmt->pptr - 1); 01282 01283 /* 01284 * Check if at least one data edit- 01285 * descriptor was found. 01286 */ 01287 01288 if (temp < 0) { 01289 data_ed = TRUE; 01290 temp = -temp; 01291 } 01292 01293 num_eds = num_eds + temp; 01294 break; 01295 01296 case 'A': /* A[w] data edit-descriptor */ 01297 data_ed = TRUE; 01298 process_arl(pfmt, A_ED); 01299 break; 01300 01301 case 'D': /* Dw.d[Ee] data edit-descriptor */ 01302 data_ed = TRUE; 01303 process_defg(pfmt, D_ED); 01304 break; 01305 01306 case 'F': /* Fw.d data edit-descriptor */ 01307 data_ed = TRUE; 01308 process_defg(pfmt, F_ED); 01309 break; 01310 01311 case 'I': /* Iw[.m] data edit-descriptor */ 01312 data_ed = TRUE; 01313 process_bioz(pfmt, I_ED); 01314 break; 01315 01316 case 'X': /* nX control edit-descriptor */ 01317 01318 if (!found_rep_count) 01319 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, 01320 FALL, 0); 01321 else 01322 if (repeat_count > MAX_FIELD_WIDTH) { 01323 fmterr(pfmt, FIELD_TOO_LARGE, 01324 FALL, num_start); 01325 repeat_count = MAX_FIELD_WIDTH; 01326 } 01327 01328 pfmt->pptr->op_code = TR_ED; 01329 pfmt->pptr->field_width = repeat_count; 01330 pfmt->pptr->rep_count = 1; 01331 pfmt->pptr = pfmt->pptr + 1; 01332 01333 GET(pfmt); 01334 break; 01335 01336 case 'H': /* nHc[c] string edit-descriptor */ 01337 fmterr(pfmt, H_IS_OBSOLETE_IN_F90, F90, 0); 01338 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, F95, 0); 01339 01340 if (found_rep_count) { 01341 register int left; 01342 01343 if (repeat_count > MAX_FIELD_WIDTH) { 01344 fmterr(pfmt, FIELD_TOO_LARGE, 01345 FALL, num_start); 01346 repeat_count = MAX_FIELD_WIDTH; 01347 } 01348 01349 left = pfmt->fmt_len - pfmt->fmt_pos; 01350 01351 if (repeat_count > left) 01352 repeat_count = (int64) left; 01353 01354 pfmt->pptr->op_code = STRING_ED; 01355 pfmt->pptr->field_width = repeat_count; 01356 pfmt->pptr->rep_count = 1; 01357 pfmt->pptr = pfmt->pptr + 1; 01358 01359 (void) strncpy((char *) pfmt->pptr, 01360 pfmt->fmt_ptr + 1, (int) repeat_count); 01361 01362 pfmt->pptr = pfmt->pptr + 1 + 01363 ((repeat_count - 1) / FMT_ENTRY_BYTE_SIZE); 01364 pfmt->fmt_ptr = pfmt->fmt_ptr + repeat_count; 01365 pfmt->fmt_pos = pfmt->fmt_pos + repeat_count; 01366 01367 GET(pfmt); 01368 01369 if (pfmt->fmt_ch == '\0') 01370 fmterr(pfmt, NONTERMINATED_LITERAL, 01371 FALL, 0); 01372 } 01373 else { 01374 fmterr(pfmt, ZERO_OR_NO_HOLLERITH_CNT, 01375 FALL, num_start); 01376 recover(pfmt); 01377 } 01378 break; 01379 01380 case '*': /* *[c]* string edit-descriptor */ 01381 case '"': /* "[c]" string edit-descriptor */ 01382 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, FALL, 0); 01383 01384 /* Break intentionally omitted - should fall through */ 01385 01386 case '\'': /* '[c]' string edit-descriptor */ 01387 process_char_string(pfmt); 01388 break; 01389 01390 case 'G': /* Gw.d[Ee] data edit-descriptor */ 01391 data_ed = TRUE; 01392 process_defg(pfmt, G_ED); 01393 break; 01394 01395 case 'E': /* Ew.d[Ee], ESw.d[Ee] or ENw.d[Ee] 01396 data edit-descriptors */ 01397 data_ed = TRUE; 01398 op_code = E_ED; 01399 old_pos = pfmt->fmt_pos; 01400 old_ptr = pfmt->fmt_ptr; 01401 01402 GET(pfmt); 01403 01404 ch = toupper(pfmt->fmt_ch); 01405 01406 if (ch == 'N' || ch == 'S') { 01407 01408 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, 01409 F77, old_pos); 01410 01411 op_code = (ch == 'N') ? EN_ED : ES_ED; 01412 01413 } 01414 else { /* Back up */ 01415 pfmt->fmt_pos = old_pos; 01416 pfmt->fmt_ptr = old_ptr; 01417 } 01418 01419 process_defg(pfmt, op_code); 01420 break; 01421 01422 case 'B': /* Bw[.m] data edit-descriptor or BN or 01423 BZ control edit-descriptors */ 01424 01425 old_pos = pfmt->fmt_pos; 01426 old_ptr = pfmt->fmt_ptr; 01427 01428 GET(pfmt); 01429 01430 ch = toupper(pfmt->fmt_ch); 01431 01432 if (ch == 'N' || ch == 'Z') { 01433 01434 if (found_rep_count) 01435 fmterr(pfmt, INVALID_REP_COUNT, 01436 FALL, num_start); 01437 01438 pfmt->pptr->op_code = (ch == 'N') ? 01439 BN_ED : BZ_ED; 01440 pfmt->pptr = pfmt->pptr + 1; 01441 01442 GET(pfmt); 01443 } 01444 else { 01445 if (repeat_count == 0) 01446 fmterr(pfmt, ZERO_REP_COUNT, 01447 FALL, num_start); 01448 01449 /* Back up */ 01450 01451 pfmt->fmt_pos = old_pos; 01452 pfmt->fmt_ptr = old_ptr; 01453 01454 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, 01455 F77, 0); 01456 01457 data_ed = TRUE; 01458 process_bioz(pfmt, B_ED); 01459 break; 01460 } 01461 break; 01462 01463 case 'R': /* Rw data edit-descriptor */ 01464 data_ed = TRUE; 01465 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, FALL, 0); 01466 process_arl(pfmt, R_ED); 01467 break; 01468 01469 case 'L': /* Lw data edit-descriptor */ 01470 data_ed = TRUE; 01471 process_arl(pfmt, L_ED); 01472 break; 01473 01474 case 'P': /* nP control edit-descriptor */ 01475 if (!found_rep_count) 01476 fmterr(pfmt, EXPECTING_INTEGER, FALL, 01477 0); 01478 01479 process_p(pfmt, (long) repeat_count); 01480 comma_req_flag = FALSE; 01481 break; 01482 01483 case 'O': /* Ow[.m] data edit-descriptor */ 01484 data_ed = TRUE; 01485 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, F77, 0); 01486 process_bioz(pfmt, O_ED); 01487 break; 01488 01489 case 'Z': /* Zw[.m] data edit-descriptor */ 01490 data_ed = TRUE; 01491 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, F77, 0); 01492 process_bioz(pfmt, Z_ED); 01493 break; 01494 01495 case '/': /* [n]/ control edit-descriptor */ 01496 if (found_rep_count) { 01497 01498 if (repeat_count > MAX_FIELD_WIDTH) { 01499 fmterr(pfmt, FIELD_TOO_LARGE, 01500 FALL, num_start); 01501 repeat_count = MAX_FIELD_WIDTH; 01502 } 01503 01504 fmterr(pfmt, REP_SLASH_NON_ANSI, 01505 F77, num_start); 01506 } 01507 01508 pfmt->pptr->op_code = SLASH_ED; 01509 pfmt->pptr->field_width = repeat_count; 01510 pfmt->pptr->rep_count = 1; 01511 pfmt->pptr = pfmt->pptr + 1; 01512 01513 comma_req_flag = FALSE; 01514 01515 GET(pfmt); 01516 break; 01517 01518 case '+': /* '+' valid only before P edit-descriptor */ 01519 GET(pfmt); 01520 01521 if (IS_DIGIT(pfmt->fmt_ch)) { 01522 register int64 size; 01523 01524 size = 0; 01525 num_start = pfmt->fmt_pos; 01526 01527 GETNUM(pfmt, size); 01528 01529 if (toupper(pfmt->fmt_ch) == 'P') { 01530 01531 pfmt->desc_col = pfmt->fmt_pos; 01532 01533 if (size > MAX_REP_COUNT) { 01534 fmterr(pfmt, FIELD_TOO_LARGE, 01535 FALL, num_start); 01536 size = MAX_REP_COUNT; 01537 } 01538 01539 process_p(pfmt, (long) size); 01540 01541 comma_req_flag = FALSE; 01542 break; /* Good exit */ 01543 } 01544 01545 fmterr(pfmt, EXPECTING_P_OR_X, FALL, 0); 01546 } 01547 else 01548 fmterr(pfmt, EXPECTING_INTEGER, FALL, 0); 01549 01550 recover(pfmt); 01551 break; 01552 01553 case '-': /* '-' valid only before P or X edit- 01554 descriptors */ 01555 comma_req_flag = process_minus(pfmt); 01556 break; 01557 01558 case ':': /* : control edit-descriptor */ 01559 pfmt->pptr->op_code = COLON_ED; 01560 pfmt->pptr = pfmt->pptr + 1; 01561 01562 GET(pfmt); 01563 01564 comma_req_flag = FALSE; 01565 break; 01566 01567 case 'Q': /* Q control edit-descriptor */ 01568 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, FALL, 0); 01569 01570 pfmt->pptr->op_code = Q_ED; 01571 pfmt->pptr = pfmt->pptr + 1; 01572 01573 GET(pfmt); 01574 01575 comma_req_flag = FALSE; 01576 data_ed = TRUE; 01577 break; 01578 01579 case '$': /* $ control edit-descriptor */ 01580 case '\\': /* \ control edit-descriptor */ 01581 fmterr(pfmt, NON_ANSI_EDIT_DESCRIPTOR, FALL, 0); 01582 01583 pfmt->pptr->op_code = DOLLAR_ED; 01584 pfmt->pptr = pfmt->pptr + 1; 01585 01586 GET(pfmt); 01587 01588 comma_req_flag = FALSE; 01589 break; 01590 01591 case 'S': /* S, SP or SS control edit-descriptor */ 01592 GET(pfmt); 01593 01594 ch = toupper(pfmt->fmt_ch); 01595 01596 if (ch == 'S' || ch == 'P') { 01597 op_code = (ch == 'S') ? SS_ED : SP_ED; 01598 GET(pfmt); 01599 } 01600 else 01601 op_code = S_ED; 01602 01603 pfmt->pptr->op_code = op_code; 01604 pfmt->pptr = pfmt->pptr + 1; 01605 break; 01606 01607 case 'T': /* T, TL or TR control edit-descriptor */ 01608 process_t(pfmt); 01609 break; 01610 01611 #ifndef _OLD_ERROR_NUMBERS 01612 case ',': /* No edit descriptor, issue warning */ 01613 fmterr(pfmt, NON_ANSI_NULL_DESCRIPTOR, FALL, 0); 01614 GET(pfmt); 01615 01616 comma_req_flag = FALSE; 01617 break; 01618 #endif 01619 01620 case ')': /* End of parentheses group */ 01621 num_eds = num_eds - 1; 01622 01623 if (num_eds == 0 && !outer_paren) 01624 fmterr(pfmt, ANSI_EMPTY_PAREN_MSG, 01625 FALL, 0); 01626 break; 01627 01628 case '\0': /* Oops, premature end of format */ 01629 fmterr(pfmt, EXPECTING_RIGHT_PAREN, FALL, 0); 01630 return(0); 01631 01632 default: /* Unknown edit-descriptor */ 01633 fmterr(pfmt, UNKNOWN_EDIT_DESCRIPTOR, FALL, 0); 01634 recover(pfmt); 01635 break; 01636 01637 } /* switch */ 01638 01639 if (pfmt->fmt_ch == ',') { 01640 register long col; 01641 01642 col = pfmt->fmt_pos; /* Position of comma */ 01643 01644 GET(pfmt); 01645 01646 if (pfmt->fmt_ch == ')') { 01647 pfmt->desc_col = col; 01648 fmterr(pfmt, COMMA_NON_ANSI, FALL, col); 01649 } 01650 } 01651 else 01652 if (comma_req_flag) 01653 switch (pfmt->fmt_ch) { 01654 01655 case ')': 01656 case ':': 01657 case '/': 01658 case '\0': 01659 break; 01660 01661 default: 01662 fmterr(pfmt, ANSI_COMMA_REQ, 01663 FALL, 0); 01664 break; 01665 } /* switch */ 01666 01667 if (pfmt->fatal_err && pfmt->caller == LIB_CALL) 01668 return(0); 01669 01670 } while (pfmt->fmt_ch != ')'); 01671 01672 if (outer_paren) { /* End of format found */ 01673 pfmt->pptr->op_code = REVERT_OP; 01674 pfmt->pptr->rep_count = pfmt->revert - pfmt->pptr; 01675 pfmt->pptr->offset = pfmt->fmt_pos; 01676 pfmt->pptr->rgcdedf = data_ed; 01677 pfmt->pptr = pfmt->pptr + 1; 01678 } 01679 else { 01680 01681 /* 01682 * End of internal parentheses group. Try to simplify the parsed 01683 * format by attempting to coalesce entries. Entries are coalesced 01684 * if one of the following conditions applies: 01685 * 01686 * 1) Empty or redundant parentheses groups. Constructs of the form: 01687 * '...()...' or '((...))' can be removed or simplified in the 01688 * parsed format. 01689 * 01690 * 2) Singly-repeated parentheses group. Constructs of the form: 01691 * '(...)' or '1(...)' can be simplified to '...'. 01692 * 01693 * 3) Single edit-descriptor parentheses group. Constructs of the 01694 * form: '...n(e)...' or '...n(m(e))...', where 'e' is any single 01695 * edit-descriptor and 'n' and 'm' are repetition counts, can be 01696 * simplified to '...ne...' or '...n*me...', respectively. 01697 * 01698 * a) If the single edit-descriptor is a P, BN, BZ, S, SP, SS, : 01699 * or $ descriptor, the repeat count is ignored. So a format 01700 * of the form: '...15(BZ)...' becomes '...BZ...'. 01701 * 01702 * b) If the single edit-descriptor is a TL, TR, T or X edit- 01703 * descriptor, the repeat count is folded into the count (width) 01704 * field. So a format of the form: '...4(5X)...' becomes 01705 * '...20X...'. 01706 * 01707 * c) For all other edit-descriptors, the repeat count is folded 01708 * into the existing repeat count. So a format of the form: 01709 * '...3(4F9.2)...' becomes '...12F9.2...'. 01710 * 01711 * Entries are NOT coalesced if their combined rep_count fields would 01712 * exceed the maximum possible rep_count. Note that any possible 01713 * reversion point must be marked before a parentheses group is removed. 01714 * 01715 * Note that two adjacent identical edit descriptors which do not span 01716 * a reversion point could be coalesced (e.g., 'I8,I8' to '2I8'); but 01717 * in this case the offset field would be incorrect for some of the 01718 * coalesced edit descriptors. If a run-time error occurred while 01719 * processing one of those edit descriptors the run-time diagnostic 01720 * might point at the wrong edit descriptor. 01721 */ 01722 01723 if (pfmt->depth == 1) 01724 pfmt->revert = ploc; /* Mark possible reversion point */ 01725 01726 if (ploc + 1 == pfmt->pptr && ploc->op_code == REPEAT_OP) { 01727 01728 /* Clear empty parentheses group and remove it */ 01729 01730 pfmt->pptr = pfmt->pptr - 1; 01731 01732 (void) memset((void *) pfmt->pptr, 0, 2 * sizeof(fmt_type)); 01733 01734 } 01735 else { 01736 01737 if ((num_eds == 1 || /* If one edit-descriptor or */ 01738 (ploc->op_code == REPEAT_OP && 01739 ploc->rep_count == 1) ) && /* Unary repeat count */ 01740 ploc->rep_count * (ploc+1)->rep_count < 01741 MAX_REP_COUNT) { 01742 01743 unsigned int size; 01744 fmt_type *ppsp; 01745 01746 /* Coalesce entries */ 01747 01748 pfmt->pptr = pfmt->pptr - 1; 01749 ppsp = ploc + 1; 01750 01751 switch (ppsp->op_code) { 01752 01753 case P_ED: 01754 case BN_ED: 01755 case BZ_ED: 01756 case COLON_ED: 01757 case S_ED: 01758 case SP_ED: 01759 case SS_ED: 01760 case T_ED: 01761 case DOLLAR_ED: 01762 01763 /* Simply ignore rep_count */ 01764 01765 break; 01766 01767 case SLASH_ED: 01768 case TL_ED: 01769 case TR_ED: 01770 01771 /* 01772 * Fold rep_count into width, 01773 * if it'll fit. 01774 */ 01775 01776 size = ploc->rep_count * 01777 ppsp->field_width; 01778 01779 if (size < MAX_FIELD_WIDTH) { 01780 ppsp->field_width = 01781 size; 01782 ppsp->rep_count = 1; 01783 } 01784 else /* Fold into rep_count */ 01785 ppsp->rep_count = 01786 ppsp->rep_count * 01787 ploc->rep_count; 01788 01789 break; 01790 01791 default: 01792 01793 /* Cascade rep_counts */ 01794 01795 ppsp->rep_count = 01796 ppsp->rep_count * 01797 ploc->rep_count; 01798 break; 01799 01800 } /* switch (ppsp->op_code) */ 01801 01802 /* Move entries */ 01803 01804 (void) memmove((void *) ploc, (void *) ppsp, 01805 (pfmt->pptr - ploc) * sizeof(fmt_type)); 01806 01807 /* Clear vacated entries */ 01808 01809 (void) memset((void *) pfmt->pptr, 0, 2 * sizeof(fmt_type)); 01810 01811 } 01812 else { 01813 pfmt->pptr->op_code = ENDREP_OP; 01814 pfmt->pptr->rep_count = ploc - pfmt->pptr; 01815 pfmt->pptr->offset = pfmt->fmt_pos; 01816 pfmt->pptr = pfmt->pptr + 1; 01817 01818 if (pfmt->maxdepth < pfmt->depth) 01819 pfmt->maxdepth = pfmt->depth; 01820 } 01821 } 01822 } 01823 01824 pfmt->depth = pfmt->depth - 1; 01825 01826 GET(pfmt); 01827 01828 if (data_ed) 01829 num_eds = -num_eds; 01830 01831 return(num_eds); 01832 01833 } /* process_paren_group */
1.7.6.1 
