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 of the GNU General Public License as 00007 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 General Public License along 00021 with this program; if not, write the Free Software Foundation, Inc., 59 00022 Temple Place - Suite 330, Boston MA 02111-1307, USA. 00023 00024 Contact information: Silicon Graphics, Inc., 1600 Amphitheatre Pky, 00025 Mountain View, CA 94043, or: 00026 00027 http://www.sgi.com 00028 00029 For further information regarding this notice, see: 00030 00031 http://oss.sgi.com/projects/GenInfo/NoticeExplan 00032 00033 */ 00034 00035 00036 00037 static char USMID[] = "\n@(#)5.0_pl/sources/lex.c 5.8 08/23/99 17:26:51\n"; 00038 00039 # include "defines.h" /* Machine dependent ifdefs */ 00040 00041 # include "host.m" /* Host machine dependent macros.*/ 00042 # include "host.h" /* Host machine dependent header.*/ 00043 # include "target.m" /* Target machine dependent macros.*/ 00044 # include "target.h" /* Target machine dependent header.*/ 00045 00046 # include "globals.m" 00047 # include "tokens.m" 00048 # include "sytb.m" 00049 # include "lex.m" 00050 # include "debug.m" 00051 00052 # ifdef _ARITH_H 00053 # include "arith.h" 00054 # endif 00055 00056 # include "globals.h" 00057 # include "tokens.h" 00058 # include "sytb.h" 00059 # include "p_globals.h" 00060 # include "lex.h" 00061 # include <errno.h> 00062 00063 /*****************************************************************\ 00064 |* function prototypes of static functions declared in this file *| 00065 \*****************************************************************/ 00066 00067 static boolean convert_const(void); 00068 static boolean fixed_get_keyword (void); 00069 static boolean free_get_keyword (void); 00070 static boolean get_directive (void); 00071 static boolean get_format_str (void); 00072 static boolean get_label (void); 00073 static boolean get_micro_directive (void); 00074 static boolean get_open_mp_directive (void); 00075 static boolean get_sgi_directive (void); 00076 static boolean get_openad_directive (void); 00077 static boolean get_operand_digit (void); 00078 static boolean get_operand_dot (void); 00079 static boolean get_operand_letter (void); 00080 static boolean get_operand_quote (void); 00081 static boolean get_operator (void); 00082 static boolean get_operator_dot (void); 00083 static boolean get_program_str (void); 00084 static boolean get_punctuator (void); 00085 static void convert_octal_literal (boolean); 00086 static void convert_hex_literal(boolean); 00087 static void convert_binary_literal(boolean); 00088 static void set_up_letter_idx_table(int *,kwd_type *, int); 00089 00090 # ifdef _DEBUG 00091 static boolean get_debug_directive (void); 00092 # endif 00093 00094 00095 /******************************************************************************\ 00096 |* *| 00097 |* Description: *| 00098 |* Init_lex is called by the main compiler driver to initialize the look *| 00099 |* ahead character to the first charcter of the first source input line. *| 00100 |* *| 00101 |* Input parameters: *| 00102 |* NONE *| 00103 |* *| 00104 |* Output parameters: *| 00105 |* NONE *| 00106 |* *| 00107 |* Returns: *| 00108 |* NOTHING *| 00109 |* *| 00110 \******************************************************************************/ 00111 00112 void init_lex (void) 00113 00114 { 00115 int word; 00116 00117 00118 TRACE (Func_Entry, "init_lex", NULL); 00119 00120 /* set function pointers for getting next char based on source form */ 00121 00122 if (source_form == Fixed_Form) { 00123 get_char = fixed_get_char; 00124 get_char_literal = fixed_get_char_literal; 00125 } 00126 else { 00127 get_char = free_get_char; 00128 get_char_literal = free_get_char_literal; 00129 } 00130 00131 00132 /* get first look ahead char of source */ 00133 00134 NEXT_LA_CH; 00135 00136 00137 /* Set N$PES sighting flag. */ 00138 00139 havent_issued_ndollarpes_ansi = TRUE; 00140 00141 00142 /* initialize initial_token used to initialize token */ 00143 00144 for (word = 0; word < NUM_ID_WDS; word++) { 00145 TOKEN_STR_WD(initial_token, word) = 0; 00146 } 00147 00148 TOKEN_LEN(initial_token) = 0; 00149 TOKEN_VALUE(initial_token) = Tok_Unknown; 00150 TOKEN_ERR(initial_token) = FALSE; 00151 TOKEN_KIND_STR(initial_token)[0] = EOS; 00152 TOKEN_KIND_LEN(initial_token) = 0; 00153 TOKEN_COLUMN(initial_token) = 0; 00154 TOKEN_LINE(initial_token) = 0; 00155 TOKEN_BUF_IDX(initial_token) = 0; 00156 TOKEN_STMT_NUM(initial_token) = 0; 00157 00158 TRACE (Func_Exit, "init_lex", NULL); 00159 00160 return; 00161 00162 } /* init_lex */ 00163 00164 /******************************************************************************\ 00165 |* *| 00166 |* Description: *| 00167 |* Used for error recovery. This keeps getting the LA_CH value until *| 00168 |* LA_CH is EOS. The token is UNDEFINED after this is called. *| 00169 |* *| 00170 |* Input parameters: *| 00171 |* NONE *| 00172 |* *| 00173 |* Output parameters: *| 00174 |* NONE *| 00175 |* *| 00176 |* Returns: *| 00177 |* NOTHING *| 00178 |* *| 00179 \******************************************************************************/ 00180 00181 void flush_LA_to_EOS (void) 00182 00183 { 00184 TRACE (Func_Entry, "flush_LA_to_EOS", NULL); 00185 00186 la_ch = stmt_EOS_la_ch; 00187 00188 TRACE (Func_Exit, "flush_LA_to_EOS", NULL); 00189 00190 return; 00191 00192 } /* flush_LA_to_EOS */ 00193 00194 /******************************************************************************\ 00195 |* *| 00196 |* Description: *| 00197 |* This routine skips to the next punctuator, discarding the intervening *| 00198 |* characters. LA_CH is set to the punctuator. Token is UNDEFINED *| 00199 |* upon exit. It skips over quoted strings, hollerith, boz constants, *| 00200 |* and other operands. Used for error recovery. *| 00201 |* *| 00202 |* Input parameters: *| 00203 |* NONE *| 00204 |* *| 00205 |* Output parameters: *| 00206 |* NONE *| 00207 |* *| 00208 |* Returns: *| 00209 |* NOTHING *| 00210 |* *| 00211 \******************************************************************************/ 00212 00213 void flush_LA_to_symbol (void) 00214 00215 { 00216 00217 TRACE (Func_Entry, "flush_LA_to_symbol", NULL); 00218 00219 do { 00220 00221 if (LA_CH_CLASS == Ch_Class_Letter) { 00222 NEXT_LA_CH; 00223 while (VALID_LA_CH) { 00224 NEXT_LA_CH; 00225 } 00226 } 00227 else if (LA_CH_CLASS == Ch_Class_Digit || LA_CH_VALUE == DBL_QUOTE || 00228 LA_CH_VALUE == QUOTE) { 00229 00230 /* Skip quoted strings, hollerith constants, and other strange stuff */ 00231 00232 get_token(Tok_Class_Opnd); 00233 } 00234 else { 00235 NEXT_LA_CH; 00236 } 00237 } 00238 while (LA_CH_CLASS != Ch_Class_EOS && LA_CH_CLASS != Ch_Class_Symbol); 00239 00240 TRACE (Func_Exit, "flush_LA_to_symbol", NULL); 00241 00242 return; 00243 00244 } /* flush_LA_to_symbol */ 00245 00246 /******************************************************************************\ 00247 |* *| 00248 |* Description: *| 00249 |* Get_token is called by the parser to construct a token out of the *| 00250 |* current look ahead character and additional characters from the input *| 00251 |* source. The parser supplies context information describing the class *| 00252 |* of token needed in the input parameter. Get_token uses the requested *| 00253 |* class to call the appropriate get_... routine to create a token. *| 00254 |* *| 00255 |* Input parameters: *| 00256 |* class parser requested token class *| 00257 |* *| 00258 |* Output parameters: *| 00259 |* la_ch next character of input source statement *| 00260 |* token token produced by scanner *| 00261 |* *| 00262 |* Returns: *| 00263 |* TRUE indicates that a token of the requested class was produced. *| 00264 |* FALSE indicates that an error was encountered. *| 00265 |* *| 00266 \******************************************************************************/ 00267 00268 boolean get_token (token_class_type class) 00269 00270 { 00271 boolean result = FALSE; 00272 int tok_len = 0; 00273 00274 00275 TRACE (Func_Entry, "get_token", NULL); 00276 00277 comp_phase = Lex_Parsing; 00278 00279 switch (class) { 00280 case Tok_Class_Id : 00281 00282 if (LA_CH_CLASS == Ch_Class_Letter || 00283 (on_off_flags.allow_leading_uscore && 00284 LA_CH_VALUE == USCORE)) { 00285 00286 sig_blank = FALSE; 00287 result = TRUE; 00288 token = initial_token; 00289 TOKEN_LINE(token) = LA_CH_LINE; 00290 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00291 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00292 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00293 TOKEN_VALUE(token) = Tok_Id; 00294 00295 while (VALID_LA_CH) { 00296 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 00297 NEXT_LA_CH; 00298 } 00299 TOKEN_LEN(token) = tok_len; 00300 00301 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 chars */ 00302 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 00303 TOKEN_LEN(token) = MAX_ID_LEN; 00304 } 00305 else if (tok_len == 5 && 00306 strcmp(TOKEN_STR(token), "N$PES") == 0 && 00307 havent_issued_ndollarpes_ansi) { 00308 PRINTMSG (TOKEN_LINE(token), 1414, Ansi, TOKEN_COLUMN(token)); 00309 havent_issued_ndollarpes_ansi = FALSE; 00310 } 00311 } 00312 break; 00313 00314 case Tok_Class_Keyword : 00315 00316 if (LA_CH_CLASS == Ch_Class_Letter) { 00317 sig_blank = FALSE; 00318 token = initial_token; 00319 TOKEN_LINE(token) = LA_CH_LINE; 00320 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00321 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00322 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00323 result = (source_form == Fixed_Form) ? 00324 fixed_get_keyword () : free_get_keyword (); 00325 } 00326 else if (LA_CH_CLASS == Ch_Class_Dir1) { 00327 00328 /* Only set to Ch_Class_Dir1 by src_input if the next letters */ 00329 /* are known to be $ (for sgi C$ directives ) */ 00330 00331 sig_blank = FALSE; 00332 token = initial_token; 00333 TOKEN_LINE(token) = LA_CH_LINE; 00334 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00335 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00336 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00337 TOKEN_VALUE(token) = Tok_Kwd_Dir; 00338 TOKEN_LEN(token) = 1; 00339 00340 for (tok_len = 0; tok_len < TOKEN_LEN(token); tok_len++) { 00341 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00342 NEXT_LA_CH; 00343 } 00344 result = TRUE; 00345 } 00346 else if (LA_CH_CLASS == Ch_Class_Dir2) { 00347 00348 00349 /* Only set to Ch_Class_Dir2 by src_input if the prefix is known */ 00350 /* to be 2 chars. There are none at this time. */ 00351 00352 sig_blank = FALSE; 00353 token = initial_token; 00354 TOKEN_LINE(token) = LA_CH_LINE; 00355 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00356 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00357 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00358 TOKEN_VALUE(token) = Tok_Kwd_Dir; 00359 TOKEN_LEN(token) = 2; 00360 00361 for (tok_len = 0; tok_len < TOKEN_LEN(token); tok_len++) { 00362 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00363 NEXT_LA_CH; 00364 } 00365 result = TRUE; 00366 } 00367 else if (LA_CH_CLASS == Ch_Class_Dir3) { 00368 00369 /* Only set to Ch_Class_Dir3 by src_input if the next letters */ 00370 /* are known to be the start of a C*$* directive */ 00371 00372 sig_blank = FALSE; 00373 token = initial_token; 00374 TOKEN_LINE(token) = LA_CH_LINE; 00375 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00376 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00377 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00378 TOKEN_VALUE(token) = Tok_Kwd_Dir; 00379 TOKEN_LEN(token) = 3; 00380 00381 for (tok_len = 0; tok_len < TOKEN_LEN(token); tok_len++) { 00382 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00383 NEXT_LA_CH; 00384 } 00385 result = TRUE; 00386 } 00387 else if (LA_CH_CLASS == Ch_Class_Dir4) { 00388 00389 /* Only set to Ch_Class_Dir4 by src_input if the next letters */ 00390 /* are known to be the start of a CMIC, CDIR, or C$PAR */ 00391 00392 sig_blank = FALSE; 00393 token = initial_token; 00394 TOKEN_LINE(token) = LA_CH_LINE; 00395 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00396 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00397 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00398 TOKEN_VALUE(token) = Tok_Kwd_Dir; 00399 TOKEN_LEN(token) = 4; 00400 00401 for (tok_len = 0; tok_len < TOKEN_LEN(token); tok_len++) { 00402 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00403 NEXT_LA_CH; 00404 } 00405 result = TRUE; 00406 } 00407 else if (LA_CH_CLASS == Ch_Class_Dir7) { 00408 00409 /* eraxxon: OpenAD directive */ 00410 /* Only set to Ch_Class_Dir7 by src_input if the next letters */ 00411 /* are known to be the start of a C$OPENAD */ 00412 00413 sig_blank = FALSE; 00414 token = initial_token; 00415 TOKEN_LINE(token) = LA_CH_LINE; 00416 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00417 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00418 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00419 TOKEN_VALUE(token) = Tok_Kwd_Dir; 00420 TOKEN_LEN(token) = 7; 00421 00422 for (tok_len = 0; tok_len < TOKEN_LEN(token); tok_len++) { 00423 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00424 NEXT_LA_CH; 00425 } 00426 result = TRUE; 00427 } 00428 else if (LA_CH_VALUE == USCORE && 00429 on_off_flags.allow_leading_uscore) { 00430 00431 sig_blank = FALSE; 00432 result = TRUE; 00433 token = initial_token; 00434 TOKEN_LINE(token) = LA_CH_LINE; 00435 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00436 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00437 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00438 TOKEN_VALUE(token) = Tok_Id; 00439 00440 while (VALID_LA_CH) { 00441 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 00442 NEXT_LA_CH; 00443 } 00444 TOKEN_LEN(token) = tok_len; 00445 00446 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 chars */ 00447 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 00448 TOKEN_LEN(token) = MAX_ID_LEN; 00449 } 00450 } 00451 00452 break; 00453 00454 case Tok_Class_Punct : 00455 if (LA_CH_CLASS == Ch_Class_Symbol || LA_CH_CLASS == Ch_Class_EOS) { 00456 sig_blank = FALSE; 00457 token = initial_token; 00458 TOKEN_LINE(token) = LA_CH_LINE; 00459 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00460 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00461 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00462 result = get_punctuator (); 00463 } 00464 break; 00465 00466 case Tok_Class_Op : 00467 if (LA_CH_CLASS == Ch_Class_Symbol) { 00468 sig_blank = FALSE; 00469 token = initial_token; 00470 TOKEN_LINE(token) = LA_CH_LINE; 00471 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00472 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00473 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00474 result = get_operator (); 00475 } 00476 break; 00477 00478 case Tok_Class_Opnd : 00479 switch (LA_CH_CLASS) { 00480 case Ch_Class_Digit: 00481 sig_blank = FALSE; 00482 token = initial_token; 00483 TOKEN_LINE(token) = LA_CH_LINE; 00484 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00485 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00486 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00487 result = get_operand_digit (); 00488 break; 00489 00490 case Ch_Class_Letter: 00491 sig_blank = FALSE; 00492 token = initial_token; 00493 TOKEN_LINE(token) = LA_CH_LINE; 00494 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00495 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00496 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00497 result = get_operand_letter (); 00498 00499 if (TOKEN_LEN(token) == 5 && 00500 strcmp(TOKEN_STR(token), "N$PES") == 0 && 00501 havent_issued_ndollarpes_ansi) { 00502 PRINTMSG (TOKEN_LINE(token), 1414, Ansi, TOKEN_COLUMN(token)); 00503 havent_issued_ndollarpes_ansi = FALSE; 00504 00505 } 00506 00507 break; 00508 00509 case Ch_Class_EOS: 00510 result = FALSE; 00511 break; 00512 00513 case Ch_Class_Symbol: 00514 if (LA_CH_VALUE == DOT) { 00515 sig_blank = FALSE; 00516 token = initial_token; 00517 TOKEN_LINE(token) = LA_CH_LINE; 00518 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00519 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00520 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00521 result = get_operand_dot (); 00522 } 00523 else if (LA_CH_VALUE == QUOTE || LA_CH_VALUE == DBL_QUOTE) { 00524 sig_blank = FALSE; 00525 token = initial_token; 00526 TOKEN_LINE(token) = LA_CH_LINE; 00527 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00528 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00529 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00530 result = get_operand_quote (); 00531 } 00532 break; 00533 } /* End switch */ 00534 break; 00535 00536 case Tok_Class_Int_Spec : 00537 if (LA_CH_CLASS == Ch_Class_Digit) { 00538 sig_blank = FALSE; 00539 result = TRUE; 00540 token = initial_token; 00541 TOKEN_LINE(token) = LA_CH_LINE; 00542 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00543 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00544 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00545 TOKEN_VALUE(token) = Tok_Const_Int; 00546 00547 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 00548 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 00549 NEXT_LA_CH; 00550 } 00551 00552 CHECK_FOR_FREE_BLANK; 00553 00554 const_buf[tok_len] = '\0'; 00555 00556 CONVERT_INT_CONST(INTEGER_DEFAULT_TYPE, tok_len, result); 00557 } 00558 break; 00559 00560 case Tok_Class_Label : 00561 if (LA_CH_CLASS == Ch_Class_Digit) { 00562 sig_blank = FALSE; 00563 token = initial_token; 00564 TOKEN_LINE(token) = LA_CH_LINE; 00565 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00566 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00567 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00568 result = get_label (); 00569 } 00570 break; 00571 00572 case Tok_Class_Construct_Def : 00573 00574 /* This could really be written as a buffer search. */ 00575 /* done at the start of every statement. JLS/jls */ 00576 /* TRUE returned if construct name of < 32 chars */ 00577 /* found and is followed by a single colon. */ 00578 00579 if (LA_CH_CLASS == Ch_Class_Letter) { 00580 sig_blank = FALSE; 00581 token = initial_token; 00582 TOKEN_LINE(token) = LA_CH_LINE; 00583 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00584 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00585 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00586 00587 while (VALID_LA_CH) { 00588 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 00589 NEXT_LA_CH; 00590 } 00591 00592 /* Check to see if this is really a construct name */ 00593 00594 if (LA_CH_VALUE != COLON) { 00595 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 00596 } 00597 else { 00598 NEXT_LA_CH; 00599 00600 if (LA_CH_VALUE != COLON) { /* id followed by :: */ 00601 if (tok_len > MAX_ID_LEN) { 00602 /* Id len exceeds maximum of 31 chars */ 00603 PRINTMSG (TOKEN_LINE(token), 67, Error, 00604 TOKEN_COLUMN(token)); 00605 tok_len = MAX_ID_LEN; 00606 } 00607 result = TRUE; 00608 TOKEN_LEN(token) = tok_len; 00609 TOKEN_VALUE(token) = Tok_Id; 00610 } 00611 else { 00612 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 00613 } 00614 } 00615 } 00616 break; 00617 00618 case Tok_Class_DO : 00619 if (LA_CH_CLASS == Ch_Class_Letter) { 00620 sig_blank = FALSE; 00621 token = initial_token; 00622 TOKEN_LINE(token) = LA_CH_LINE; 00623 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00624 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00625 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00626 00627 if (source_form == Fixed_Form) { 00628 00629 /* This is a kludge to get around the fixed source form problem*/ 00630 /* of DOUBLE possibly being a DO stmt (e.g. DO uble = ...). */ 00631 /* It is assumed the DOUBLE was previously parsed as type */ 00632 /* specification statement and failed making the check a DO */ 00633 /* stmt necessary. Since DOUBLE has already been seen, this */ 00634 /* routine is rather trivial but must be done in order to get */ 00635 /* the line and column information in the loop variable token */ 00636 /* (UBLE) correct if this is indeed a DO stmt. */ 00637 00638 TOKEN_VALUE(token) = Tok_Kwd_Do; 00639 result = TRUE; 00640 00641 if (LA_CH_VALUE != 'D') { /* Abort compilation */ 00642 00643 /* Invalid character encountered; expected keyword */ 00644 /* DO following failed parse of type spec DOUBLE */ 00645 00646 /* Following is a detailed description of when message 38 */ 00647 /* issues. The parser encountered a DOUBLE keyword at the */ 00648 /* beginning of a statement and attempted to parse the */ 00649 /* statement as a type specifier and failed. The parser */ 00650 /* has to special case this situation by reseting the */ 00651 /* scanner input and asking for the DO keyword using */ 00652 /* Tok_Class_Do in get_token, because DOUBLE could possibly */ 00653 /* be a DO statement in fixed source form */ 00654 /* (e.g. DO uble = ...). The scanner assumes DOUBLE had */ 00655 /* been previously fetched as a token and therefore the */ 00656 /* routine that gets the DO keyword (fixed_get_DO_keyword) */ 00657 /* makes assumptions by expecting DO. */ 00658 00659 PRINTMSG (LA_CH_LINE, 38, Internal, LA_CH_COLUMN); 00660 } 00661 NEXT_LA_CH; 00662 00663 if (LA_CH_VALUE != 'O') { /* Abort compilation - see above */ 00664 PRINTMSG (LA_CH_LINE, 38, Internal, LA_CH_COLUMN); 00665 } 00666 00667 TOKEN_STR(token)[0] = 'D'; 00668 TOKEN_STR(token)[1] = 'O'; 00669 TOKEN_LEN(token) = 2; 00670 NEXT_LA_CH; 00671 } 00672 else { 00673 result = free_get_keyword (); 00674 } 00675 00676 } 00677 break; 00678 00679 case Tok_Class_Dir_Kwd : 00680 if (LA_CH_CLASS == Ch_Class_Letter) { 00681 sig_blank = FALSE; 00682 token = initial_token; 00683 TOKEN_LINE(token) = LA_CH_LINE; 00684 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00685 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00686 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00687 result = get_directive (); 00688 } 00689 break; 00690 00691 case Tok_Class_Mic_Kwd : 00692 if (LA_CH_CLASS == Ch_Class_Letter) { 00693 sig_blank = FALSE; 00694 token = initial_token; 00695 TOKEN_LINE(token) = LA_CH_LINE; 00696 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00697 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00698 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00699 result = get_micro_directive (); 00700 } 00701 break; 00702 00703 case Tok_Class_Open_Mp_Dir_Kwd : 00704 if (LA_CH_CLASS == Ch_Class_Letter) { 00705 sig_blank = FALSE; 00706 token = initial_token; 00707 TOKEN_LINE(token) = LA_CH_LINE; 00708 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00709 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00710 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00711 result = get_open_mp_directive (); 00712 } 00713 break; 00714 00715 case Tok_Class_SGI_Dir_Kwd : 00716 if (LA_CH_CLASS == Ch_Class_Letter) { 00717 sig_blank = FALSE; 00718 token = initial_token; 00719 TOKEN_LINE(token) = LA_CH_LINE; 00720 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00721 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00722 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00723 result = get_sgi_directive (); 00724 } 00725 break; 00726 00727 case Tok_Class_OpenAD_Dir_Kwd : 00728 /* eraxxon: OpenAD directive */ 00729 if (LA_CH_CLASS == Ch_Class_Letter) { 00730 sig_blank = FALSE; 00731 token = initial_token; 00732 TOKEN_LINE(token) = LA_CH_LINE; 00733 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00734 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00735 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00736 result = get_openad_directive (); 00737 } 00738 break; 00739 00740 # ifdef _DEBUG 00741 case Tok_Class_Dbg_Kwd : 00742 if (LA_CH_CLASS == Ch_Class_Letter) { 00743 sig_blank = FALSE; 00744 token = initial_token; 00745 TOKEN_LINE(token) = LA_CH_LINE; 00746 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00747 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00748 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00749 result = get_debug_directive (); 00750 } 00751 break; 00752 # endif 00753 00754 case Tok_Class_Format_Str : 00755 if (LA_CH_VALUE == LPAREN) { 00756 sig_blank = FALSE; 00757 token = initial_token; 00758 TOKEN_LINE(token) = LA_CH_LINE; 00759 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00760 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00761 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00762 result = get_format_str (); 00763 } 00764 break; 00765 00766 case Tok_Class_Program_Str : 00767 if (LA_CH_VALUE == LPAREN) { 00768 sig_blank = FALSE; 00769 token = initial_token; 00770 TOKEN_LINE(token) = LA_CH_LINE; 00771 TOKEN_COLUMN(token) = LA_CH_COLUMN; 00772 TOKEN_BUF_IDX(token) = LA_CH_BUF_IDX; 00773 TOKEN_STMT_NUM(token) = LA_CH_STMT_NUM; 00774 result = get_program_str (); 00775 } 00776 break; 00777 } /* switch */ 00778 00779 comp_phase = Pass1_Parsing; 00780 00781 TRACE (Func_Exit, "get_token", NULL); 00782 00783 return (result); 00784 00785 } /* get_token */ 00786 00787 /******************************************************************************\ 00788 |* *| 00789 |* Description: *| 00790 |* Reset_lex is called by the parser to backup the token stream for a *| 00791 |* rescan. The reset_src_input routine is called to reposition to the *| 00792 |* requested source input character and reset the global la_ch. *| 00793 |* Be careful not to call this routine, if token is already EOS. *| 00794 |* Strange and not so wonderful things can happen. *| 00795 |* *| 00796 |* Input parameters: *| 00797 |* buf_idx stmt_buf_idx to reset to. *| 00798 |* stmt_num gets passed on to reset_src_input. *| 00799 |* *| 00800 |* Output parameters: *| 00801 |* la_ch next character of input source statement *| 00802 |* *| 00803 |* Returns: *| 00804 |* NONE *| 00805 |* *| 00806 \******************************************************************************/ 00807 00808 void reset_lex (int buf_idx, 00809 int stmt_num) 00810 00811 { 00812 TRACE (Func_Entry, "reset_lex", NULL); 00813 00814 reset_src_input (--buf_idx, stmt_num); 00815 00816 NEXT_LA_CH; 00817 00818 TRACE (Func_Exit, "reset_lex", NULL); 00819 00820 return; 00821 00822 } /* reset_lex */ 00823 00824 /******************************************************************************\ 00825 |* *| 00826 |* Description: *| 00827 |* Get_directive is called by the get_token routine to attempt *| 00828 |* recognition of a directive keyword by matching the look ahead char *| 00829 |* and following characters of class Ch_Class_Letter with entries in the *| 00830 |* kwd_dir table. If a keyword is not found, an id token is created. *| 00831 |* *| 00832 |* Input parameters: *| 00833 |* la_ch first character of directive kwd token *| 00834 |* *| 00835 |* Output parameters: *| 00836 |* la_ch next character of input source statement *| 00837 |* token token created by get_directive *| 00838 |* *| 00839 |* Returns: *| 00840 |* TRUE indicates a keyword or id token was produced. *| 00841 |* FALSE indicates that an error was encountered. *| 00842 |* *| 00843 \******************************************************************************/ 00844 00845 static boolean get_directive (void) 00846 00847 { 00848 int beg_idx; 00849 la_type la_queue[MAX_KWD_LEN + 1]; 00850 int letter_idx; 00851 int lim_idx; 00852 int tok_len = 0; 00853 00854 00855 TRACE (Func_Entry, "get_directive", NULL); 00856 00857 # ifdef _DEBUG 00858 if (LA_CH_CLASS != Ch_Class_Letter) { 00859 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 00860 "get_directive", "letter"); 00861 } 00862 # endif 00863 00864 TOKEN_VALUE(token) = Tok_Id; 00865 00866 /* check for any directive keywords starting with look ahead char */ 00867 00868 letter_idx = LA_CH_VALUE - 'A'; 00869 beg_idx = kwd_dir_idx[letter_idx]; 00870 lim_idx = kwd_dir_idx[letter_idx+1]; 00871 00872 if (beg_idx != lim_idx) { 00873 00874 #ifdef _DEBUG 00875 if (kwd_dir_len[beg_idx] > MAX_ID_LEN) { 00876 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 00877 beg_idx, kwd_dir_len[beg_idx]); 00878 } 00879 # endif 00880 00881 while ((LA_CH_CLASS == Ch_Class_Letter || LA_CH_VALUE == USCORE) && 00882 tok_len < kwd_dir_len[beg_idx]) { 00883 00884 /* Internal error if kwd_dir len ever exceeds MAX_ID_LEN */ 00885 /* There is no check. Assume keywords may never be > 31 chars. */ 00886 00887 la_queue[tok_len] = la_ch; 00888 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 00889 tok_len++; 00890 NEXT_LA_CH; 00891 } 00892 00893 TOKEN_LEN(token) = tok_len; 00894 00895 if (tok_len >= kwd_dir_len[lim_idx-1]) { 00896 00897 /* compare token string to directive keyword entries */ 00898 00899 while (beg_idx < lim_idx) { 00900 00901 if (kwd_dir_len[beg_idx] <= tok_len) { 00902 00903 if (strncmp(TOKEN_STR(token), 00904 kwd_dir[beg_idx].name, 00905 kwd_dir_len[beg_idx]) == IDENTICAL) { 00906 00907 /* the following chars and preceding letter can't be */ 00908 /* part of a keyword on full length match of string. */ 00909 00910 if (tok_len == kwd_dir_len[beg_idx] && 00911 (LA_CH_VALUE == USCORE || 00912 LA_CH_VALUE == DOLLAR || 00913 LA_CH_VALUE == AT_SIGN)) { 00914 } 00915 else { 00916 TOKEN_VALUE(token) = kwd_dir[beg_idx].value; 00917 00918 /* adjust la_ch to be char following keyword */ 00919 00920 if (tok_len > kwd_dir_len[beg_idx]) { 00921 tok_len = kwd_dir_len[beg_idx]; 00922 la_ch = la_queue[tok_len]; 00923 TOKEN_LEN(token) = tok_len; 00924 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 00925 } 00926 break; 00927 } 00928 } 00929 } 00930 00931 beg_idx++; 00932 00933 } /* while */ 00934 } /* if */ 00935 } /* if */ 00936 00937 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 00938 00939 while (VALID_LA_CH) { 00940 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 00941 NEXT_LA_CH; 00942 } 00943 00944 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 00945 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 00946 tok_len = MAX_ID_LEN; 00947 } 00948 00949 TOKEN_LEN(token) = tok_len; 00950 } 00951 00952 TRACE (Func_Exit, "get_directive", NULL); 00953 00954 return (TRUE); 00955 00956 } /* get_directive */ 00957 00958 /******************************************************************************\ 00959 |* *| 00960 |* Description: *| 00961 |* Get_format_str is called by the get_token routine to attempt *| 00962 |* recognition of a format string by using the look ahead character and *| 00963 |* following characters of the input source. Blanks and embedded *| 00964 |* comments are removed from the string. *| 00965 |* *| 00966 |* Input parameters: *| 00967 |* la_ch opening paren of format string *| 00968 |* *| 00969 |* Output parameters: *| 00970 |* la_ch next character of input source statement *| 00971 |* token token created by get_format_str *| 00972 |* *| 00973 |* Returns: *| 00974 |* TRUE indicates a format string token was produced. *| 00975 |* FALSE indicates that an error was encountered. *| 00976 |* *| 00977 \******************************************************************************/ 00978 00979 static boolean get_format_str (void) 00980 00981 { 00982 00983 TRACE (Func_Entry, "get_format_str", NULL); 00984 00985 # ifdef _DEBUG 00986 if (LA_CH_VALUE != LPAREN) { 00987 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 00988 "get_format_str", "("); 00989 } 00990 # endif 00991 00992 TOKEN_VALUE(token) = Tok_Const_Char; 00993 TOKEN_CONST_TBL_IDX(token) = put_format_in_tbl(); 00994 00995 TRACE (Func_Exit, "get_format_str", NULL); 00996 00997 return (TRUE); 00998 00999 } /* get_format_str */ 01000 01001 01002 /******************************************************************************\ 01003 |* *| 01004 |* Description: *| 01005 |* Fixed_get_keyword is called in fixed input source form by the *| 01006 |* get_token routine to attempt recognition of a keyword by matching the *| 01007 |* look ahead char and following characters of class Ch_Class_Letter *| 01008 |* with entries in the kwd table. If a keyword is not found, an id *| 01009 |* token is created. *| 01010 |* *| 01011 |* Input parameters: *| 01012 |* la_ch first character of kwd token *| 01013 |* *| 01014 |* Output parameters: *| 01015 |* la_ch next character of input source statement *| 01016 |* token token created by get_keyword *| 01017 |* *| 01018 |* Returns: *| 01019 |* TRUE indicates a keyword or id token was produced. *| 01020 |* FALSE indicates that an error was encountered. *| 01021 |* *| 01022 \******************************************************************************/ 01023 01024 static boolean fixed_get_keyword (void) 01025 01026 { 01027 int beg_idx; 01028 la_type la_queue[MAX_KWD_LEN + 1]; 01029 int letter_idx; 01030 int lim_idx; 01031 int tok_len = 0; 01032 01033 01034 TRACE (Func_Entry, "fixed_get_keyword", NULL); 01035 01036 01037 # ifdef _DEBUG 01038 if (LA_CH_CLASS != Ch_Class_Letter) { 01039 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01040 "fixed_get_keyword", "letter"); 01041 } 01042 # endif 01043 01044 TOKEN_VALUE(token) = Tok_Id; 01045 01046 /* check for any keywords starting with look ahead char */ 01047 letter_idx = LA_CH_VALUE - 'A'; 01048 01049 beg_idx = kwd_idx[letter_idx]; 01050 lim_idx = kwd_idx[letter_idx+1]; 01051 01052 if (beg_idx != lim_idx) { 01053 01054 #ifdef _DEBUG 01055 if (kwd_len[beg_idx] > MAX_ID_LEN) { 01056 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 01057 beg_idx, kwd_len[beg_idx]); 01058 } 01059 # endif 01060 01061 while (LA_CH_CLASS == Ch_Class_Letter && tok_len < kwd_len[beg_idx]) { 01062 la_queue[tok_len] = la_ch; 01063 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 01064 tok_len++; 01065 NEXT_LA_CH; 01066 } 01067 01068 TOKEN_LEN(token) = tok_len; 01069 01070 if (tok_len >= kwd_len[lim_idx-1]) { 01071 01072 /* compare token string to keyword entries */ 01073 01074 while (beg_idx < lim_idx) { 01075 if (tok_len >= kwd_len[beg_idx]) { 01076 if (strncmp(TOKEN_STR(token), 01077 kwd[beg_idx].name, 01078 kwd_len[beg_idx]) == IDENTICAL) { 01079 01080 /* the following chars and preceding letter can't be */ 01081 /* part of a keyword on full length match of string. */ 01082 01083 if (tok_len == kwd_len[beg_idx] && 01084 ! on_off_flags.allow_leading_uscore && 01085 (LA_CH_VALUE == USCORE || 01086 LA_CH_VALUE == DOLLAR || 01087 LA_CH_VALUE == AT_SIGN)) { 01088 } 01089 else { 01090 TOKEN_VALUE(token) = kwd[beg_idx].value; 01091 01092 /* adjust la_ch to be char following keyword */ 01093 01094 if (tok_len > kwd_len[beg_idx]) { 01095 tok_len = kwd_len[beg_idx]; 01096 la_ch = la_queue[tok_len]; 01097 TOKEN_LEN(token) = tok_len; 01098 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01099 } 01100 break; 01101 } 01102 } 01103 } 01104 01105 beg_idx++; 01106 01107 } /* while */ 01108 } /* if */ 01109 } /* if */ 01110 01111 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 01112 01113 while (VALID_LA_CH) { 01114 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01115 NEXT_LA_CH; 01116 } 01117 01118 if (tok_len > MAX_ID_LEN) { /* Id len exceeds max of 31 characters */ 01119 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01120 tok_len = MAX_ID_LEN; 01121 } 01122 TOKEN_LEN(token) = tok_len; 01123 } 01124 01125 TRACE (Func_Exit, "fixed_get_keyword", NULL); 01126 01127 return (TRUE); 01128 01129 } /* fixed_get_keyword */ 01130 01131 /******************************************************************************\ 01132 |* *| 01133 |* Description: *| 01134 |* Free_get_keyword is called in free input source form by the *| 01135 |* get_token routine to attempt recognition of a keyword by matching the *| 01136 |* look ahead char and following characters of class Ch_Class_Letter *| 01137 |* with entries in the kwd table. If a keyword is not found, an id *| 01138 |* token is created. *| 01139 |* *| 01140 |* Input parameters: *| 01141 |* la_ch first character of kwd token *| 01142 |* *| 01143 |* Output parameters: *| 01144 |* la_ch next character of input source statement *| 01145 |* token token created by get_keyword *| 01146 |* *| 01147 |* Returns: *| 01148 |* TRUE indicates a keyword or id token was produced. *| 01149 |* FALSE indicates that an error was encountered. *| 01150 |* *| 01151 \******************************************************************************/ 01152 01153 static boolean free_get_keyword (void) 01154 01155 { 01156 boolean all_letters = TRUE; 01157 int beg_idx; 01158 la_type la_queue[MAX_KWD_LEN + 1]; 01159 int letter_idx; 01160 int lim_idx; 01161 int tok_len = 0; 01162 01163 01164 TRACE (Func_Entry, "free_get_keyword", NULL); 01165 01166 # ifdef _DEBUG 01167 if (LA_CH_CLASS != Ch_Class_Letter) { 01168 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01169 "free_get_keyword", "letter"); 01170 } 01171 # endif 01172 01173 TOKEN_VALUE(token) = Tok_Id; 01174 01175 while (VALID_LA_CH) { 01176 if (LA_CH_CLASS != Ch_Class_Letter) { /* non letter in kwd */ 01177 all_letters = FALSE; 01178 } 01179 01180 if (tok_len < MAX_KWD_LEN) { 01181 la_queue[tok_len] = la_ch; 01182 } 01183 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01184 NEXT_LA_CH; 01185 } 01186 01187 TOKEN_LEN(token) = tok_len; 01188 01189 if (all_letters && tok_len > 1 && tok_len <= MAX_KWD_LEN) { 01190 01191 /* check for any keywords starting with first character of token */ 01192 01193 letter_idx = TOKEN_STR(token)[0] - 'A'; 01194 beg_idx = kwd_idx[letter_idx]; 01195 lim_idx = kwd_idx[letter_idx+1]; 01196 01197 /* compare token string to keyword entries of matching length */ 01198 while (beg_idx < lim_idx) { 01199 if (kwd_len[beg_idx] == tok_len) { 01200 if (EQUAL_STRS(TOKEN_STR(token), kwd[beg_idx].name)) { 01201 TOKEN_VALUE(token) = kwd[beg_idx].value; 01202 break; 01203 } 01204 } 01205 beg_idx++; 01206 } 01207 01208 if (beg_idx == lim_idx) { 01209 01210 /* check for any alternate form keywords starting with first char */ 01211 01212 beg_idx = alt_kwd_idx[letter_idx]; 01213 lim_idx = alt_kwd_idx[letter_idx+1]; 01214 01215 /* compare token string to alternate form keyword entries */ 01216 01217 while (beg_idx < lim_idx) { 01218 if (alt_kwd[beg_idx].len == tok_len) { 01219 if (EQUAL_STRS(TOKEN_STR(token), alt_kwd[beg_idx].name)) { 01220 TOKEN_VALUE(token) = alt_kwd[beg_idx].value; 01221 tok_len = alt_kwd[beg_idx].val_len; 01222 TOKEN_LEN(token) = tok_len; 01223 01224 /* adjust la_ch to be char following first keyword */ 01225 01226 la_ch = la_queue[tok_len]; 01227 01228 /* would'nt be here if we just passed a sig blank so .. */ 01229 01230 sig_blank = FALSE; 01231 01232 /* reset src input buffer and column index to la_ch pos */ 01233 01234 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01235 break; 01236 } 01237 } 01238 01239 beg_idx++; 01240 01241 } /* while */ 01242 } /* if */ 01243 } /* if */ 01244 01245 if (TOKEN_VALUE(token) == Tok_Id) { 01246 01247 if (tok_len > MAX_ID_LEN) { /* Id len exceeds max of 31 characters */ 01248 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01249 tok_len = MAX_ID_LEN; 01250 } 01251 TOKEN_LEN(token) = tok_len; 01252 } 01253 01254 TRACE (Func_Exit, "free_get_keyword", NULL); 01255 01256 return (TRUE); 01257 01258 } /* free_get_keyword */ 01259 01260 /******************************************************************************\ 01261 |* *| 01262 |* Description: *| 01263 |* Get_label is called by the get_token routine to attempt recognition *| 01264 |* of a label token using the look ahead character and following *| 01265 |* characters of the input source. *| 01266 |* *| 01267 |* Input parameters: *| 01268 |* la_ch first character of label token *| 01269 |* *| 01270 |* Output parameters: *| 01271 |* la_ch next character of input source statement *| 01272 |* token token created by get_label *| 01273 |* *| 01274 |* Returns: *| 01275 |* TRUE indicates a label token was produced. *| 01276 |* FALSE indicates that an error was encountered. *| 01277 |* *| 01278 \******************************************************************************/ 01279 01280 static boolean get_label (void) 01281 01282 { 01283 int tok_cnt = 0; 01284 int tok_len = 0; 01285 01286 01287 TRACE (Func_Entry, "get_label", NULL); 01288 01289 # ifdef _DEBUG 01290 if (LA_CH_CLASS != Ch_Class_Digit) { 01291 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01292 "get_label", "digit"); 01293 } 01294 # endif 01295 01296 TOKEN_VALUE(token) = Tok_Label; 01297 01298 while (LA_CH_VALUE == ZERO && !sig_blank) { 01299 NEXT_LA_CH; 01300 tok_cnt++; 01301 } 01302 01303 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 01304 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01305 NEXT_LA_CH; 01306 tok_cnt++; 01307 } 01308 01309 CHECK_FOR_FREE_BLANK; 01310 01311 TOKEN_LEN(token) = tok_len; 01312 01313 if (tok_cnt == 0 || tok_cnt > 5) { 01314 /* Label len exceeds max of 5 digits */ 01315 PRINTMSG (TOKEN_LINE(token), 68, Error, TOKEN_COLUMN(token)); 01316 01317 /* truncate the long label so that error won't cascade */ 01318 TOKEN_STR(token)[5] = '\0'; 01319 TOKEN_LEN(token) = 5; 01320 TOKEN_ERR(token) = TRUE; 01321 } 01322 else if (tok_len == 0) { /* Label must have at least one non-zero digit */ 01323 PRINTMSG (TOKEN_LINE(token), 69, Error, TOKEN_COLUMN(token)); 01324 ADD_TO_TOKEN_STR ('0', TOKEN_LEN(token)); 01325 TOKEN_ERR(token) = TRUE; 01326 } 01327 01328 TRACE (Func_Exit, "get_label", NULL); 01329 01330 return (TRUE); 01331 01332 } /* get_label */ 01333 01334 /******************************************************************************\ 01335 |* *| 01336 |* Description: *| 01337 |* Get_micro_directive is called by the get_token routine to attempt *| 01338 |* recognition of a microtasking keyword by matching the look ahead char *| 01339 |* and following characters of class Ch_Class_Letter with entries in the *| 01340 |* kwd_mic table. If a keyword is not found, an id token is created. *| 01341 |* *| 01342 |* Input parameters: *| 01343 |* la_ch first character of microtasking kwd token *| 01344 |* *| 01345 |* Output parameters: *| 01346 |* la_ch next character of input source statement *| 01347 |* token token created by get_micro_directive *| 01348 |* *| 01349 |* Returns: *| 01350 |* TRUE indicates a keyword or id token was produced. *| 01351 |* FALSE indicates that an error was encountered. *| 01352 |* *| 01353 \******************************************************************************/ 01354 01355 static boolean get_micro_directive (void) 01356 01357 { 01358 int beg_idx; 01359 la_type la_queue[MAX_KWD_LEN + 1]; 01360 int letter_idx; 01361 int lim_idx; 01362 int tok_len = 0; 01363 01364 01365 TRACE (Func_Entry, "get_micro_directive", NULL); 01366 01367 # ifdef _DEBUG 01368 if (LA_CH_CLASS != Ch_Class_Letter) { 01369 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01370 "get_micro_directive", "letter"); 01371 } 01372 # endif 01373 01374 TOKEN_VALUE(token) = Tok_Id; 01375 01376 /* check for any microtasking keywords starting with look ahead char */ 01377 letter_idx = LA_CH_VALUE - 'A'; 01378 01379 beg_idx = kwd_mic_idx[letter_idx]; 01380 lim_idx = kwd_mic_idx[letter_idx+1]; 01381 01382 if (beg_idx != lim_idx) { 01383 01384 #ifdef _DEBUG 01385 if (kwd_mic_len[beg_idx] > MAX_ID_LEN) { 01386 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 01387 beg_idx, kwd_mic_len[beg_idx]); 01388 } 01389 # endif 01390 01391 while (LA_CH_CLASS == Ch_Class_Letter && tok_len < kwd_mic_len[beg_idx]) { 01392 la_queue[tok_len] = la_ch; 01393 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 01394 tok_len++; 01395 NEXT_LA_CH; 01396 } 01397 01398 TOKEN_LEN(token) = tok_len; 01399 01400 if (tok_len >= kwd_mic_len[lim_idx-1]) { 01401 01402 /* compare token string to microtasking keyword entries */ 01403 01404 while (beg_idx < lim_idx) { 01405 01406 if (kwd_mic_len[beg_idx] <= tok_len) { 01407 01408 if (strncmp(TOKEN_STR(token), 01409 kwd_mic[beg_idx].name, 01410 kwd_mic_len[beg_idx]) == IDENTICAL) { 01411 01412 /* the following chars and preceding letter can't be */ 01413 /* part of a keyword on full length match of string. */ 01414 01415 if (tok_len == kwd_mic_len[beg_idx] && 01416 (LA_CH_VALUE == USCORE || 01417 LA_CH_VALUE == DOLLAR || 01418 LA_CH_VALUE == AT_SIGN)) { 01419 } 01420 else { 01421 TOKEN_VALUE(token) = kwd_mic[beg_idx].value; 01422 01423 /* adjust la_ch to be char following keyword */ 01424 01425 if (tok_len > kwd_mic_len[beg_idx]) { 01426 tok_len = kwd_mic_len[beg_idx]; 01427 la_ch = la_queue[tok_len]; 01428 TOKEN_LEN(token) = tok_len; 01429 01430 /* reset src input buffer and col index to la_ch pos */ 01431 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01432 } 01433 break; 01434 } 01435 } 01436 } /* if */ 01437 01438 beg_idx++; 01439 01440 } /* while */ 01441 } /* if */ 01442 } /* if */ 01443 01444 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 01445 01446 while (VALID_LA_CH) { 01447 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01448 NEXT_LA_CH; 01449 } 01450 01451 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 01452 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01453 tok_len = MAX_ID_LEN; 01454 } 01455 TOKEN_LEN(token) = tok_len; 01456 } 01457 01458 TRACE (Func_Exit, "get_micro_directive", NULL); 01459 01460 return (TRUE); 01461 01462 } /* get_micro_directive */ 01463 01464 /******************************************************************************\ 01465 |* *| 01466 |* Description: *| 01467 |* is_par_directive is called by the classify_line routines to decide if *| 01468 |* a !$par prefix is followed by a directive or a comment. It must *| 01469 |* remain similar in design to get_par_directive. *| 01470 |* *| 01471 |* Input parameters: *| 01472 |* *| 01473 |* Output parameters: *| 01474 |* *| 01475 |* Returns: *| 01476 |* TRUE indicates a directive. *| 01477 |* FALSE indicates that the line is a comment. *| 01478 |* *| 01479 \******************************************************************************/ 01480 01481 boolean is_par_directive (int start_idx) 01482 01483 { 01484 int beg_idx; 01485 int blank = ' '; 01486 int idx; 01487 boolean is_directive = FALSE; 01488 int letter_idx; 01489 int lim_idx; 01490 int newline = '\n'; 01491 int tab = '\t'; 01492 char upper_str[MAX_KWD_LEN + 1]; 01493 int str_len = 0; 01494 01495 01496 TRACE (Func_Entry, "is_par_directive", NULL); 01497 01498 idx = start_idx; 01499 01500 while (nxt_line[idx] == blank || nxt_line[idx] == tab) { 01501 idx++; 01502 } 01503 01504 if (ch_class[nxt_line[idx]] != Ch_Class_Letter) { 01505 goto EXIT; 01506 } 01507 else if (islower(nxt_line[idx])) { 01508 upper_str[str_len] = TOUPPER(nxt_line[idx]); 01509 } 01510 else { 01511 upper_str[str_len] = nxt_line[idx]; 01512 } 01513 str_len++; 01514 idx++; 01515 01516 letter_idx = upper_str[0] - 'A'; 01517 01518 beg_idx = kwd_sgi_dir_idx[letter_idx]; 01519 lim_idx = kwd_sgi_dir_idx[letter_idx+1]; 01520 01521 if (beg_idx == lim_idx) { 01522 goto EXIT; 01523 } 01524 01525 while (nxt_line[idx] != newline && str_len <= kwd_sgi_dir_len[beg_idx]) { 01526 if (nxt_line[idx] == blank || nxt_line[idx] == tab) { 01527 idx++; 01528 } 01529 else { 01530 if (ch_class[nxt_line[idx]] != Ch_Class_Letter && 01531 nxt_line[idx] != USCORE) { 01532 break; 01533 } 01534 else if (islower(nxt_line[idx])) { 01535 upper_str[str_len] = TOUPPER(nxt_line[idx]); 01536 } 01537 else { 01538 upper_str[str_len] = nxt_line[idx]; 01539 } 01540 str_len++; 01541 idx++; 01542 } 01543 } 01544 01545 upper_str[str_len] = '\0'; 01546 01547 01548 if (str_len >= kwd_sgi_dir_len[lim_idx-1]) { 01549 01550 while (beg_idx < lim_idx) { 01551 01552 if (kwd_sgi_dir_len[beg_idx] <= str_len) { 01553 01554 if (strncmp(upper_str, 01555 kwd_sgi_dir[beg_idx].name, 01556 kwd_sgi_dir_len[beg_idx]) == IDENTICAL) { 01557 01558 switch (kwd_sgi_dir[beg_idx].value) { 01559 case Tok_SGI_Dir_Barrier: 01560 case Tok_SGI_Dir_Criticalsection: 01561 case Tok_SGI_Dir_Endcriticalsection: 01562 case Tok_SGI_Dir_Endparallel: 01563 case Tok_SGI_Dir_Endpdo: 01564 case Tok_SGI_Dir_Endpsection: 01565 case Tok_SGI_Dir_Endpsections: 01566 case Tok_SGI_Dir_Endsingleprocess: 01567 case Tok_SGI_Dir_Parallel: 01568 case Tok_SGI_Dir_Paralleldo: 01569 case Tok_SGI_Dir_Pdo: 01570 case Tok_SGI_Dir_Psection: 01571 case Tok_SGI_Dir_Psections: 01572 case Tok_SGI_Dir_Section: 01573 case Tok_SGI_Dir_Singleprocess: 01574 01575 is_directive = TRUE; 01576 break; 01577 01578 default: 01579 break; 01580 } 01581 break; 01582 } 01583 } /* if */ 01584 01585 beg_idx++; 01586 01587 } /* while */ 01588 } /* if */ 01589 01590 EXIT: 01591 01592 TRACE (Func_Exit, "is_par_directive", NULL); 01593 01594 return (is_directive); 01595 01596 } /* is_par_directive */ 01597 01598 /******************************************************************************\ 01599 |* *| 01600 |* Description: *| 01601 |* get_open_mp_directive is called by the get_token routine to attempt *| 01602 |* recognition of a !$OMP keyword by matching the look ahead char *| 01603 |* and following characters of class Ch_Class_Letter with entries in the *| 01604 |* kwd_mic table. If a keyword is not found, an id token is created. *| 01605 |* *| 01606 |* Input parameters: *| 01607 |* la_ch first character of !$ kwd token *| 01608 |* *| 01609 |* Output parameters: *| 01610 |* la_ch next character of input source statement *| 01611 |* token token created by get_open_mp_directive *| 01612 |* *| 01613 |* Returns: *| 01614 |* TRUE indicates a keyword or id token was produced. *| 01615 |* FALSE indicates that an error was encountered. *| 01616 |* *| 01617 \******************************************************************************/ 01618 01619 static boolean get_open_mp_directive (void) 01620 01621 { 01622 int beg_idx; 01623 la_type la_queue[MAX_KWD_LEN + 1]; 01624 int letter_idx; 01625 int lim_idx; 01626 int tok_len = 0; 01627 01628 01629 TRACE (Func_Entry, "get_open_mp_directive", NULL); 01630 01631 # ifdef _DEBUG 01632 if (LA_CH_CLASS != Ch_Class_Letter) { 01633 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01634 "get_open_mp_directive", "letter"); 01635 } 01636 # endif 01637 01638 TOKEN_VALUE(token) = Tok_Id; 01639 01640 /* check for any keywords starting with look ahead char */ 01641 letter_idx = LA_CH_VALUE - 'A'; 01642 01643 beg_idx = kwd_open_mp_dir_idx[letter_idx]; 01644 lim_idx = kwd_open_mp_dir_idx[letter_idx+1]; 01645 01646 if (beg_idx != lim_idx) { 01647 01648 #ifdef _DEBUG 01649 if (kwd_open_mp_dir_len[beg_idx] > MAX_ID_LEN) { 01650 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 01651 beg_idx, kwd_open_mp_dir_len[beg_idx]); 01652 } 01653 # endif 01654 01655 while ((LA_CH_CLASS == Ch_Class_Letter || 01656 LA_CH_CLASS == Ch_Class_Digit || 01657 LA_CH_VALUE == USCORE) && 01658 tok_len < kwd_open_mp_dir_len[beg_idx]) { 01659 la_queue[tok_len] = la_ch; 01660 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 01661 tok_len++; 01662 NEXT_LA_CH; 01663 } 01664 01665 TOKEN_LEN(token) = tok_len; 01666 01667 if (tok_len >= kwd_open_mp_dir_len[lim_idx-1]) { 01668 01669 /* compare token string to keyword entries */ 01670 01671 while (beg_idx < lim_idx) { 01672 01673 if (kwd_open_mp_dir_len[beg_idx] <= tok_len) { 01674 01675 if (strncmp(TOKEN_STR(token), 01676 kwd_open_mp_dir[beg_idx].name, 01677 kwd_open_mp_dir_len[beg_idx]) == IDENTICAL) { 01678 01679 /* the following chars and preceding letter can't be */ 01680 /* part of a keyword on full length match of string. */ 01681 01682 if (tok_len == kwd_open_mp_dir_len[beg_idx] && 01683 (LA_CH_VALUE == USCORE || 01684 LA_CH_VALUE == DOLLAR || 01685 LA_CH_VALUE == AT_SIGN)) { 01686 } 01687 else { 01688 TOKEN_VALUE(token) = kwd_open_mp_dir[beg_idx].value; 01689 01690 /* adjust la_ch to be char following keyword */ 01691 01692 if (tok_len > kwd_open_mp_dir_len[beg_idx]) { 01693 tok_len = kwd_open_mp_dir_len[beg_idx]; 01694 la_ch = la_queue[tok_len]; 01695 TOKEN_LEN(token) = tok_len; 01696 01697 /* reset src input buffer and col index to la_ch pos */ 01698 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01699 } 01700 break; 01701 } 01702 } 01703 } /* if */ 01704 01705 beg_idx++; 01706 01707 } /* while */ 01708 } /* if */ 01709 } /* if */ 01710 01711 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 01712 01713 while (VALID_LA_CH) { 01714 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01715 NEXT_LA_CH; 01716 } 01717 01718 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 01719 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01720 tok_len = MAX_ID_LEN; 01721 } 01722 TOKEN_LEN(token) = tok_len; 01723 } 01724 01725 TRACE (Func_Exit, "get_open_mp_directive", NULL); 01726 01727 return (TRUE); 01728 01729 } /* get_open_mp_directive */ 01730 01731 /******************************************************************************\ 01732 |* *| 01733 |* Description: *| 01734 |* get_sgi_directive is called by the get_token routine to attempt *| 01735 |* recognition of a !$ (sgi) keyword by matching the look ahead char *| 01736 |* and following characters of class Ch_Class_Letter with entries in the *| 01737 |* kwd_mic table. If a keyword is not found, an id token is created. *| 01738 |* *| 01739 |* Input parameters: *| 01740 |* la_ch first character of !$ kwd token *| 01741 |* *| 01742 |* Output parameters: *| 01743 |* la_ch next character of input source statement *| 01744 |* token token created by get_sgi_directive *| 01745 |* *| 01746 |* Returns: *| 01747 |* TRUE indicates a keyword or id token was produced. *| 01748 |* FALSE indicates that an error was encountered. *| 01749 |* *| 01750 \******************************************************************************/ 01751 01752 static boolean get_sgi_directive (void) 01753 01754 { 01755 int beg_idx; 01756 la_type la_queue[MAX_KWD_LEN + 1]; 01757 int letter_idx; 01758 int lim_idx; 01759 int tok_len = 0; 01760 01761 01762 TRACE (Func_Entry, "get_sgi_directive", NULL); 01763 01764 # ifdef _DEBUG 01765 if (LA_CH_CLASS != Ch_Class_Letter) { 01766 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01767 "get_sgi_directive", "letter"); 01768 } 01769 # endif 01770 01771 TOKEN_VALUE(token) = Tok_Id; 01772 01773 /* check for any keywords starting with look ahead char */ 01774 letter_idx = LA_CH_VALUE - 'A'; 01775 01776 beg_idx = kwd_sgi_dir_idx[letter_idx]; 01777 lim_idx = kwd_sgi_dir_idx[letter_idx+1]; 01778 01779 if (beg_idx != lim_idx) { 01780 01781 #ifdef _DEBUG 01782 if (kwd_sgi_dir_len[beg_idx] > MAX_ID_LEN) { 01783 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 01784 beg_idx, kwd_sgi_dir_len[beg_idx]); 01785 } 01786 # endif 01787 01788 while ((LA_CH_CLASS == Ch_Class_Letter || 01789 LA_CH_CLASS == Ch_Class_Digit || 01790 LA_CH_VALUE == USCORE) && 01791 tok_len < kwd_sgi_dir_len[beg_idx]) { 01792 la_queue[tok_len] = la_ch; 01793 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 01794 tok_len++; 01795 NEXT_LA_CH; 01796 } 01797 01798 TOKEN_LEN(token) = tok_len; 01799 01800 if (tok_len >= kwd_sgi_dir_len[lim_idx-1]) { 01801 01802 /* compare token string to keyword entries */ 01803 01804 while (beg_idx < lim_idx) { 01805 01806 if (kwd_sgi_dir_len[beg_idx] <= tok_len) { 01807 01808 if (strncmp(TOKEN_STR(token), 01809 kwd_sgi_dir[beg_idx].name, 01810 kwd_sgi_dir_len[beg_idx]) == IDENTICAL) { 01811 01812 /* the following chars and preceding letter can't be */ 01813 /* part of a keyword on full length match of string. */ 01814 01815 if (tok_len == kwd_sgi_dir_len[beg_idx] && 01816 (LA_CH_VALUE == USCORE || 01817 LA_CH_VALUE == DOLLAR || 01818 LA_CH_VALUE == AT_SIGN)) { 01819 } 01820 else { 01821 TOKEN_VALUE(token) = kwd_sgi_dir[beg_idx].value; 01822 01823 /* adjust la_ch to be char following keyword */ 01824 01825 if (tok_len > kwd_sgi_dir_len[beg_idx]) { 01826 tok_len = kwd_sgi_dir_len[beg_idx]; 01827 la_ch = la_queue[tok_len]; 01828 TOKEN_LEN(token) = tok_len; 01829 01830 /* reset src input buffer and col index to la_ch pos */ 01831 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01832 } 01833 break; 01834 } 01835 } 01836 } /* if */ 01837 01838 beg_idx++; 01839 01840 } /* while */ 01841 } /* if */ 01842 } /* if */ 01843 01844 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 01845 01846 while (VALID_LA_CH) { 01847 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01848 NEXT_LA_CH; 01849 } 01850 01851 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 01852 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01853 tok_len = MAX_ID_LEN; 01854 } 01855 TOKEN_LEN(token) = tok_len; 01856 } 01857 01858 TRACE (Func_Exit, "get_sgi_directive", NULL); 01859 01860 return (TRUE); 01861 01862 } /* get_sgi_directive */ 01863 01864 /******************************************************************************\ 01865 |* *| 01866 |* Description: *| 01867 |* get_openad_directive is called by the get_token routine to attempt *| 01868 |* recognition of a !$OPENAD$ keyword by matching the look ahead char *| 01869 |* and following characters of class Ch_Class_Letter with entries in the *| 01870 |* kwd_mic table. If a keyword is not found, an id token is created. *| 01871 |* *| 01872 |* Input parameters: *| 01873 |* la_ch first character of !$ kwd token *| 01874 |* *| 01875 |* Output parameters: *| 01876 |* la_ch next character of input source statement *| 01877 |* token token created by get_open_mp_directive *| 01878 |* *| 01879 |* Returns: *| 01880 |* TRUE indicates a keyword or id token was produced. *| 01881 |* FALSE indicates that an error was encountered. *| 01882 |* *| 01883 |* eraxxon: OpenAD directive *| 01884 |* *| 01885 \******************************************************************************/ 01886 01887 static boolean get_openad_directive (void) 01888 01889 { 01890 int beg_idx; 01891 la_type la_queue[MAX_KWD_LEN + 1]; 01892 int letter_idx; 01893 int lim_idx; 01894 int tok_len = 0; 01895 01896 01897 TRACE (Func_Entry, "get_openad_directive", NULL); 01898 01899 # ifdef _DEBUG 01900 if (LA_CH_CLASS != Ch_Class_Letter) { 01901 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 01902 "get_openad_directive", "letter"); 01903 } 01904 # endif 01905 01906 TOKEN_VALUE(token) = Tok_Id; 01907 01908 /* check for any keywords starting with look ahead char */ 01909 letter_idx = LA_CH_VALUE - 'A'; 01910 01911 beg_idx = kwd_openad_dir_idx[letter_idx]; 01912 lim_idx = kwd_openad_dir_idx[letter_idx+1]; 01913 01914 if (beg_idx != lim_idx) { 01915 01916 #ifdef _DEBUG 01917 if (kwd_openad_dir_len[beg_idx] > MAX_ID_LEN) { 01918 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 01919 beg_idx, kwd_openad_dir_len[beg_idx]); 01920 } 01921 # endif 01922 01923 while ((LA_CH_CLASS == Ch_Class_Letter || 01924 LA_CH_CLASS == Ch_Class_Digit || 01925 LA_CH_VALUE == USCORE) && 01926 tok_len < kwd_openad_dir_len[beg_idx]) { 01927 la_queue[tok_len] = la_ch; 01928 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 01929 tok_len++; 01930 NEXT_LA_CH; 01931 } 01932 01933 TOKEN_LEN(token) = tok_len; 01934 01935 if (tok_len >= kwd_openad_dir_len[lim_idx-1]) { 01936 01937 /* compare token string to keyword entries */ 01938 01939 while (beg_idx < lim_idx) { 01940 01941 if (kwd_openad_dir_len[beg_idx] <= tok_len) { 01942 01943 if (strncmp(TOKEN_STR(token), 01944 kwd_openad_dir[beg_idx].name, 01945 kwd_openad_dir_len[beg_idx]) == IDENTICAL) { 01946 01947 /* the following chars and preceding letter can't be */ 01948 /* part of a keyword on full length match of string. */ 01949 01950 if (tok_len == kwd_openad_dir_len[beg_idx] && 01951 (LA_CH_VALUE == USCORE || 01952 LA_CH_VALUE == DOLLAR || 01953 LA_CH_VALUE == AT_SIGN)) { 01954 } 01955 else { 01956 TOKEN_VALUE(token) = kwd_openad_dir[beg_idx].value; 01957 01958 /* adjust la_ch to be char following keyword */ 01959 01960 if (tok_len > kwd_openad_dir_len[beg_idx]) { 01961 tok_len = kwd_openad_dir_len[beg_idx]; 01962 la_ch = la_queue[tok_len]; 01963 TOKEN_LEN(token) = tok_len; 01964 01965 /* reset src input buffer and col index to la_ch pos */ 01966 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 01967 } 01968 break; 01969 } 01970 } 01971 } /* if */ 01972 01973 beg_idx++; 01974 01975 } /* while */ 01976 } /* if */ 01977 } /* if */ 01978 01979 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 01980 01981 while (VALID_LA_CH) { 01982 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 01983 NEXT_LA_CH; 01984 } 01985 01986 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 01987 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 01988 tok_len = MAX_ID_LEN; 01989 } 01990 TOKEN_LEN(token) = tok_len; 01991 } 01992 01993 TRACE (Func_Exit, "get_openad_directive", NULL); 01994 01995 return (TRUE); 01996 01997 } /* get_openad_directive */ 01998 01999 02000 /******************************************************************************\ 02001 |* *| 02002 |* Description: *| 02003 |* is_dollar_directive is called by the classify_line routines to decide *| 02004 |* if a !$ prefix is followed by a directive or a comment. It must *| 02005 |* remain similar in design to get_dollar_directive. *| 02006 |* *| 02007 |* Input parameters: *| 02008 |* *| 02009 |* Output parameters: *| 02010 |* *| 02011 |* Returns: *| 02012 |* TRUE indicates a directive. *| 02013 |* FALSE indicates that the line is a comment. *| 02014 |* *| 02015 \******************************************************************************/ 02016 02017 boolean is_dollar_directive (int start_idx) 02018 02019 { 02020 int beg_idx; 02021 int blank = ' '; 02022 int idx; 02023 boolean is_directive = FALSE; 02024 int letter_idx; 02025 int lim_idx; 02026 int newline = '\n'; 02027 int tab = '\t'; 02028 char upper_str[MAX_KWD_LEN + 1]; 02029 int str_len = 0; 02030 02031 02032 TRACE (Func_Entry, "is_dollar_directive", NULL); 02033 02034 idx = start_idx; 02035 02036 while (nxt_line[idx] == blank || nxt_line[idx] == tab) { 02037 idx++; 02038 } 02039 02040 if (ch_class[nxt_line[idx]] != Ch_Class_Letter) { 02041 goto EXIT; 02042 } 02043 else if (islower(nxt_line[idx])) { 02044 upper_str[str_len] = TOUPPER(nxt_line[idx]); 02045 } 02046 else { 02047 upper_str[str_len] = nxt_line[idx]; 02048 } 02049 str_len++; 02050 idx++; 02051 02052 letter_idx = upper_str[0] - 'A'; 02053 02054 beg_idx = kwd_sgi_dir_idx[letter_idx]; 02055 lim_idx = kwd_sgi_dir_idx[letter_idx+1]; 02056 02057 if (beg_idx == lim_idx) { 02058 goto EXIT; 02059 } 02060 02061 while (nxt_line[idx] != newline && str_len <= kwd_sgi_dir_len[beg_idx]) { 02062 if (nxt_line[idx] == blank || nxt_line[idx] == tab) { 02063 idx++; 02064 } 02065 else { 02066 if (ch_class[nxt_line[idx]] != Ch_Class_Letter && 02067 nxt_line[idx] != USCORE) { 02068 break; 02069 } 02070 else if (islower(nxt_line[idx])) { 02071 upper_str[str_len] = TOUPPER(nxt_line[idx]); 02072 } 02073 else { 02074 upper_str[str_len] = nxt_line[idx]; 02075 } 02076 str_len++; 02077 idx++; 02078 } 02079 } 02080 02081 upper_str[str_len] = '\0'; 02082 02083 02084 if (str_len >= kwd_sgi_dir_len[lim_idx-1]) { 02085 02086 while (beg_idx < lim_idx) { 02087 02088 if (kwd_sgi_dir_len[beg_idx] <= str_len) { 02089 02090 if (strncmp(upper_str, 02091 kwd_sgi_dir[beg_idx].name, 02092 kwd_sgi_dir_len[beg_idx]) == IDENTICAL) { 02093 02094 switch (kwd_sgi_dir[beg_idx].value) { 02095 case Tok_SGI_Dir_Distribute: 02096 case Tok_SGI_Dir_Distribute_Reshape: 02097 case Tok_SGI_Dir_Doacross: 02098 case Tok_SGI_Dir_Dynamic: 02099 case Tok_SGI_Dir_Chunk: 02100 case Tok_SGI_Dir_Mp_Schedtype: 02101 case Tok_SGI_Dir_Page_Place: 02102 case Tok_SGI_Dir_Redistribute: 02103 case Tok_SGI_Dir_Copyin: 02104 02105 is_directive = TRUE; 02106 break; 02107 02108 default: 02109 break; 02110 } 02111 break; 02112 } 02113 } /* if */ 02114 02115 beg_idx++; 02116 02117 } /* while */ 02118 } /* if */ 02119 02120 EXIT: 02121 02122 TRACE (Func_Exit, "is_dollar_directive", NULL); 02123 02124 return (is_directive); 02125 02126 } /* is_dollar_directive */ 02127 02128 /******************************************************************************\ 02129 |* *| 02130 |* Description: *| 02131 |* is_star_directive is called by the classify_line routines to decide if*| 02132 |* a !*$* prefix is followed by a directive or a comment. It must *| 02133 |* remain similar in design to get_star_directive. *| 02134 |* *| 02135 |* Input parameters: *| 02136 |* *| 02137 |* Output parameters: *| 02138 |* *| 02139 |* Returns: *| 02140 |* TRUE indicates a directive. *| 02141 |* FALSE indicates that the line is a comment. *| 02142 |* *| 02143 \******************************************************************************/ 02144 02145 boolean is_star_directive (int start_idx) 02146 02147 { 02148 int beg_idx; 02149 int blank = ' '; 02150 int idx; 02151 boolean is_directive = FALSE; 02152 int letter_idx; 02153 int lim_idx; 02154 int newline = '\n'; 02155 int tab = '\t'; 02156 char upper_str[MAX_KWD_LEN + 1]; 02157 int str_len = 0; 02158 02159 02160 TRACE (Func_Entry, "is_star_directive", NULL); 02161 02162 idx = start_idx; 02163 02164 while (nxt_line[idx] == blank || nxt_line[idx] == tab) { 02165 idx++; 02166 } 02167 02168 if (ch_class[nxt_line[idx]] != Ch_Class_Letter) { 02169 goto EXIT; 02170 } 02171 else if (islower(nxt_line[idx])) { 02172 upper_str[str_len] = TOUPPER(nxt_line[idx]); 02173 } 02174 else { 02175 upper_str[str_len] = nxt_line[idx]; 02176 } 02177 str_len++; 02178 idx++; 02179 02180 letter_idx = upper_str[0] - 'A'; 02181 02182 beg_idx = kwd_sgi_dir_idx[letter_idx]; 02183 lim_idx = kwd_sgi_dir_idx[letter_idx+1]; 02184 02185 if (beg_idx == lim_idx) { 02186 goto EXIT; 02187 } 02188 02189 while (nxt_line[idx] != newline && str_len <= kwd_sgi_dir_len[beg_idx]) { 02190 if (nxt_line[idx] == blank || nxt_line[idx] == tab) { 02191 idx++; 02192 } 02193 else { 02194 if (ch_class[nxt_line[idx]] != Ch_Class_Letter && 02195 nxt_line[idx] != USCORE) { 02196 break; 02197 } 02198 else if (islower(nxt_line[idx])) { 02199 upper_str[str_len] = TOUPPER(nxt_line[idx]); 02200 } 02201 else { 02202 upper_str[str_len] = nxt_line[idx]; 02203 } 02204 str_len++; 02205 idx++; 02206 } 02207 } 02208 02209 upper_str[str_len] = '\0'; 02210 02211 02212 if (str_len >= kwd_sgi_dir_len[lim_idx-1]) { 02213 02214 while (beg_idx < lim_idx) { 02215 02216 if (kwd_sgi_dir_len[beg_idx] <= str_len) { 02217 02218 if (strncmp(upper_str, 02219 kwd_sgi_dir[beg_idx].name, 02220 kwd_sgi_dir_len[beg_idx]) == IDENTICAL) { 02221 02222 switch (kwd_sgi_dir[beg_idx].value) { 02223 case Tok_SGI_Dir_Align_Symbol: 02224 case Tok_SGI_Dir_Aggressiveinner: 02225 case Tok_SGI_Dir_Assert: 02226 case Tok_SGI_Dir_Blockable: 02227 case Tok_SGI_Dir_Blockingsize: 02228 case Tok_SGI_Dir_Concurrentize: 02229 case Tok_SGI_Dir_Fill_Symbol: 02230 case Tok_SGI_Dir_Fission: 02231 case Tok_SGI_Dir_Fissionable: 02232 case Tok_SGI_Dir_Fusable: 02233 case Tok_SGI_Dir_Flush: 02234 case Tok_SGI_Dir_Fuse: 02235 case Tok_SGI_Dir_Inline: 02236 case Tok_SGI_Dir_Interchange: 02237 case Tok_SGI_Dir_Ipa: 02238 case Tok_SGI_Dir_Limit: 02239 case Tok_SGI_Dir_Minconcurrent: 02240 case Tok_SGI_Dir_Noblocking: 02241 case Tok_SGI_Dir_Noconcurrentize: 02242 case Tok_SGI_Dir_Nofission: 02243 case Tok_SGI_Dir_Nofusion: 02244 case Tok_SGI_Dir_Noinline: 02245 case Tok_SGI_Dir_Nointerchange: 02246 case Tok_SGI_Dir_Noipa: 02247 case Tok_SGI_Dir_Opaque: 02248 case Tok_SGI_Dir_Optional: 02249 case Tok_SGI_Dir_Prefetch: 02250 case Tok_SGI_Dir_Prefetch_Manual: 02251 case Tok_SGI_Dir_Prefetch_Ref: 02252 case Tok_SGI_Dir_Prefetch_Ref_Disable: 02253 case Tok_SGI_Dir_Purpleconditional: 02254 case Tok_SGI_Dir_Purpleunconditional: 02255 case Tok_SGI_Dir_Regionbegin: 02256 case Tok_SGI_Dir_Regionend: 02257 case Tok_SGI_Dir_Section_Gp: 02258 case Tok_SGI_Dir_Section_Non_Gp: 02259 case Tok_SGI_Dir_Unroll: 02260 02261 is_directive = TRUE; 02262 break; 02263 02264 default: 02265 break; 02266 } 02267 break; 02268 } 02269 } /* if */ 02270 02271 beg_idx++; 02272 02273 } /* while */ 02274 } /* if */ 02275 02276 EXIT: 02277 02278 TRACE (Func_Exit, "is_star_directive", NULL); 02279 02280 return (is_directive); 02281 02282 } /* is_star_directive */ 02283 02284 /******************************************************************************\ 02285 |* *| 02286 |* Description: *| 02287 |* Get_operand_digit is called by the get_token routine to attempt *| 02288 |* recognition of integer constants, real constants, boolean hollerith *| 02289 |* constants of the form nH..., nL..., or nR..., boolean octal constants *| 02290 |* of the form ...B, and character literal constants of non-default kind *| 02291 |* by examining the look ahead character and following characters of the *| 02292 |* input source. *| 02293 |* *| 02294 |* Input parameters: *| 02295 |* la_ch first character of operand token *| 02296 |* *| 02297 |* Output parameters: *| 02298 |* la_ch next character of input source statement *| 02299 |* token token produced by get_operand_digit *| 02300 |* *| 02301 |* Returns: *| 02302 |* TRUE indicates an operand token was produced. *| 02303 |* FALSE indicates that an error was encountered. *| 02304 |* *| 02305 \******************************************************************************/ 02306 02307 static boolean get_operand_digit (void) 02308 02309 { 02310 char delim; 02311 char exponent = BLANK; 02312 boolean had_letter = FALSE; 02313 boolean had_zero = FALSE; 02314 int hollerith_len = 0; 02315 int i; 02316 boolean result = TRUE; 02317 la_type save_ch; 02318 int tok_len = 0; 02319 02320 TRACE (Func_Entry, "get_operand_digit", NULL); 02321 02322 # ifdef _DEBUG 02323 if (LA_CH_CLASS != Ch_Class_Digit) { 02324 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 02325 "get_operand_digit", "digit"); 02326 } 02327 # endif 02328 02329 TOKEN_VALUE(token) = Tok_Const_Int; 02330 02331 /* skip leading zeros */ 02332 while (LA_CH_CLASS == Ch_Class_Digit && 02333 !sig_blank && 02334 LA_CH_VALUE == ZERO) { 02335 02336 had_zero = TRUE; 02337 NEXT_LA_CH; 02338 } 02339 02340 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02341 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02342 NEXT_LA_CH; 02343 } 02344 02345 if (tok_len == 0 && had_zero) { 02346 ADD_TO_CONST_BUF (ZERO, tok_len); 02347 } 02348 02349 /* check for optional decimal point or operator */ 02350 02351 if (LA_CH_VALUE == DOT && !sig_blank) { 02352 02353 /* check for dot-op form operator */ 02354 save_ch = la_ch; 02355 02356 NEXT_LA_CH; 02357 02358 while (LA_CH_CLASS == Ch_Class_Letter) { 02359 had_letter = TRUE; 02360 NEXT_LA_CH; 02361 } 02362 02363 if (LA_CH_VALUE == DOT && had_letter) { 02364 02365 /* reset src input buffer and column index to la_ch pos */ 02366 /* Have digits followed by a dot operator. */ 02367 02368 la_ch = save_ch; 02369 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 02370 } 02371 else { /* have decimal point in real constant */ 02372 TOKEN_VALUE(token) = Tok_Const_Real; 02373 02374 /* reset src input buffer and column index to la_ch pos */ 02375 la_ch = save_ch; 02376 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 02377 sig_blank = FALSE; 02378 02379 /* add decimal point to constant */ 02380 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02381 NEXT_LA_CH; 02382 02383 /* check for optional fractional digits of real constant */ 02384 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02385 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02386 NEXT_LA_CH; 02387 } 02388 } 02389 } /* if */ 02390 02391 /* check for optional exponent letter in real constant */ 02392 02393 if ((LA_CH_VALUE == 'D' || LA_CH_VALUE == 'E' || LA_CH_VALUE == 'Q') && 02394 !sig_blank) { 02395 02396 switch (LA_CH_VALUE) { 02397 case 'D': 02398 TOKEN_VALUE(token) = Tok_Const_Dbl; 02399 break; 02400 02401 case 'E': 02402 TOKEN_VALUE(token) = Tok_Const_Real; 02403 break; 02404 02405 case 'Q': 02406 02407 # if defined(_QUAD_PRECISION) 02408 TOKEN_VALUE(token) = Tok_Const_Quad; 02409 # else 02410 TOKEN_VALUE(token) = Tok_Const_Dbl; 02411 PRINTMSG(TOKEN_LINE(token), 1348, Caution, 02412 TOKEN_COLUMN(token)); 02413 # endif 02414 break; 02415 02416 } 02417 02418 exponent = LA_CH_VALUE; 02419 02420 ADD_TO_CONST_BUF ('E', tok_len); 02421 02422 NEXT_LA_CH; 02423 02424 /* check for optional sign in exponent */ 02425 if ((LA_CH_VALUE == PLUS || LA_CH_VALUE == MINUS) && !sig_blank) { 02426 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02427 NEXT_LA_CH; 02428 } 02429 02430 /* check for required digits of exponent */ 02431 02432 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02433 do { 02434 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02435 NEXT_LA_CH; 02436 } 02437 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02438 } 02439 else { /* D, E or Q must be followed by an exponent */ 02440 PRINTMSG (LA_CH_LINE, 1308, Error, LA_CH_COLUMN); 02441 result = FALSE; 02442 } 02443 02444 /* check that kind-param doesn't follow real const with exponent 'D' */ 02445 02446 if (LA_CH_VALUE == USCORE && 02447 (exponent == 'D' || 02448 exponent == 'Q') && 02449 !sig_blank) { 02450 02451 /* Can't have a kind-param if it's a D or Q exponent */ 02452 02453 PRINTMSG (TOKEN_LINE(token), 1309, Error, TOKEN_COLUMN(token)); 02454 result = FALSE; 02455 } 02456 } /* if */ 02457 02458 TOKEN_LEN(token) = tok_len; 02459 const_buf[tok_len] = '\0'; 02460 02461 /* check for optional kind-param suffix on integer or real constant, or */ 02462 /* integer form of kind-param prefix on character literal. */ 02463 02464 if (LA_CH_VALUE == USCORE && !sig_blank) { 02465 NEXT_LA_CH; 02466 02467 tok_len = 0; 02468 02469 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02470 do { 02471 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02472 NEXT_LA_CH; 02473 } 02474 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02475 02476 if (tok_len > MAX_ID_LEN) { 02477 tok_len = MAX_ID_LEN; 02478 PRINTMSG(LA_CH_LINE, 101, Error, LA_CH_COLUMN); 02479 result = FALSE; 02480 } 02481 TOKEN_KIND_LEN(token) = tok_len; 02482 TOKEN_KIND_STR(token)[tok_len] = EOS; 02483 } 02484 else if (LA_CH_CLASS == Ch_Class_Letter && !sig_blank) { 02485 do { 02486 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02487 NEXT_LA_CH; 02488 } 02489 while (VALID_LA_CH); 02490 02491 if (tok_len > MAX_ID_LEN) { 02492 tok_len = MAX_ID_LEN; 02493 PRINTMSG(LA_CH_LINE, 101, Error, LA_CH_COLUMN); 02494 result = FALSE; 02495 } 02496 TOKEN_KIND_LEN(token) = tok_len; 02497 TOKEN_KIND_STR(token)[tok_len] = EOS; 02498 } 02499 else if ((LA_CH_VALUE == QUOTE || LA_CH_VALUE == DBL_QUOTE) && 02500 !sig_blank) { 02501 02502 /* check that kind-param is integer value */ 02503 02504 if (TOKEN_VALUE(token) == Tok_Const_Real) { 02505 02506 /* Kind param on literal const must be integer or symbolic name */ 02507 02508 PRINTMSG (TOKEN_LINE(token), 89, Error, TOKEN_COLUMN(token)); 02509 result = FALSE; 02510 } 02511 else { 02512 for (i = 0; i <= TOKEN_LEN(token); i++) { 02513 TOKEN_KIND_STR(token)[i] = const_buf[i]; 02514 } 02515 TOKEN_KIND_LEN(token) = TOKEN_LEN(token); 02516 } 02517 02518 TOKEN_VALUE(token) = Tok_Const_Char; 02519 02520 delim = LA_CH_VALUE; 02521 NEXT_LA_CH; 02522 02523 result = convert_const() && result; 02524 02525 TOKEN_CONST_TBL_IDX(token) = put_char_const_in_tbl ('\0', &tok_len); 02526 02527 if (LA_CH_VALUE != delim){ 02528 PRINTMSG (TOKEN_LINE(token), 83, Error, TOKEN_COLUMN(token), delim); 02529 result = FALSE; 02530 } 02531 else { 02532 NEXT_LA_CH; 02533 } 02534 02535 TOKEN_LEN(token) = tok_len; 02536 02537 goto EXIT; 02538 } 02539 else { /* Kind param on literal const must be integer or symbolic name */ 02540 PRINTMSG (LA_CH_LINE, 89, Error, LA_CH_COLUMN); 02541 result = FALSE; 02542 } 02543 } 02544 02545 /* check for boolean octal suffix */ 02546 else if (LA_CH_VALUE == 'B' && !sig_blank) { 02547 TOKEN_VALUE(token) = Tok_Const_Boolean; 02548 TOKEN_KIND_STR(token)[0] = LA_CH_VALUE; 02549 TOKEN_KIND_STR(token)[1] = EOS; 02550 TOKEN_KIND_LEN(token) = 1; 02551 02552 /* Boolean constants are non-standard */ 02553 02554 PRINTMSG (TOKEN_LINE(token), 90, Ansi, TOKEN_COLUMN(token)); 02555 02556 if (tok_len > MAX_OCT_CONST_LEN) { 02557 PRINTMSG(TOKEN_LINE(token), 91, Error, TOKEN_COLUMN(token), 02558 tok_len, MAX_OCT_CONST_LEN); 02559 } 02560 else if (tok_len == MAX_OCT_CONST_LEN) { 02561 02562 if (const_buf[0] < '0' || const_buf[0] > '1') { 02563 /* The value exceeds the range. */ 02564 02565 PRINTMSG (TOKEN_LINE(token), 92, Error, TOKEN_COLUMN(token)); 02566 result = FALSE; 02567 } 02568 } 02569 02570 /* validate that all digits of token are octal digits */ 02571 02572 tok_len = 0; 02573 02574 while (IS_OCT_DIGIT(const_buf[tok_len])) { 02575 tok_len++; 02576 } 02577 02578 if (const_buf[tok_len] != EOS) { /* Invalid digit in octal const */ 02579 PRINTMSG(TOKEN_LINE(token), 93, Error, TOKEN_COLUMN(token), 02580 const_buf[tok_len]); 02581 result = FALSE; 02582 } 02583 NEXT_LA_CH; 02584 02585 if (result) { /* convert const boolean */ 02586 convert_octal_literal(FALSE); 02587 } 02588 else { 02589 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 02590 } 02591 } 02592 02593 /* check for hollerith prefix */ 02594 02595 else if ((LA_CH_VALUE == 'H' || 02596 LA_CH_VALUE == 'L' || 02597 LA_CH_VALUE == 'R') && !sig_blank) { 02598 02599 /* digit string is length of hollerith string */ 02600 02601 for (i = 0; i <= TOKEN_LEN(token); i++) { 02602 TOKEN_STR(token)[i] = const_buf[i]; 02603 } 02604 02605 hollerith_len = atoi (TOKEN_STR(token)); 02606 TOKEN_VALUE(token)= Tok_Const_Hollerith; 02607 02608 /* Hollerith constant form is non-standard */ 02609 02610 PRINTMSG (TOKEN_LINE(token), 96, Ansi, TOKEN_COLUMN(token)); 02611 02612 if (hollerith_len > TARGET_CHARS_PER_WORD && LA_CH_VALUE == 'R') { 02613 02614 /* Hollerith constant must be 8 (4 on sparc) */ 02615 /* characters or less in "R" form */ 02616 02617 PRINTMSG (TOKEN_LINE(token), 94, Error, TOKEN_COLUMN(token), 02618 TARGET_CHARS_PER_WORD); 02619 result = FALSE; 02620 } 02621 02622 TOKEN_KIND_STR(token)[0] = LA_CH_VALUE; 02623 TOKEN_KIND_STR(token)[1] = EOS; 02624 TOKEN_KIND_LEN(token) = 1; 02625 02626 if (hollerith_len) { 02627 NEXT_LA_CH_LITERAL; 02628 02629 TOKEN_CONST_TBL_IDX(token) = 02630 put_char_const_in_tbl (TOKEN_KIND_STR(token)[0], &tok_len); 02631 02632 TOKEN_LEN(token) = tok_len; 02633 02634 if (tok_len < hollerith_len) { 02635 02636 /* Hollerith constant contains fewer characters than specified */ 02637 02638 PRINTMSG(TOKEN_LINE(token), 84, Error, TOKEN_COLUMN(token), 02639 hollerith_len, tok_len); 02640 result = FALSE; 02641 } 02642 02643 # ifdef _TARGET_LITTLE_ENDIAN 02644 if (TOKEN_KIND_STR(token)[0] != 'R') { 02645 CN_HOLLERITH_ENDIAN(TOKEN_CONST_TBL_IDX(token)) = TRUE; 02646 } 02647 # endif 02648 02649 switch(TOKEN_KIND_STR(token)[0]) { 02650 case 'H': 02651 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = H_Hollerith; 02652 break; 02653 02654 case 'L': 02655 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = L_Hollerith; 02656 break; 02657 02658 case 'R': 02659 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = R_Hollerith; 02660 break; 02661 02662 } 02663 02664 } 02665 else { 02666 TOKEN_STR(token)[0] = EOS; 02667 TOKEN_LEN(token) = 0; 02668 02669 /* Number of characters in hollerith specifier must be non-zero */ 02670 02671 PRINTMSG (TOKEN_LINE(token), 85, Error, TOKEN_COLUMN(token)); 02672 result = FALSE; 02673 } 02674 02675 goto EXIT; 02676 } /* else if */ 02677 02678 CHECK_FOR_FREE_BLANK; 02679 02680 if (result) { 02681 switch (TOKEN_VALUE(token)) { 02682 case Tok_Const_Int : 02683 case Tok_Const_Real : 02684 result = convert_const(); 02685 break; 02686 case Tok_Const_Dbl : 02687 02688 # ifdef _TARGET_OS_MAX 02689 if (! cmd_line_flags.s_default32 && 02690 on_off_flags.enable_double_precision) { 02691 PRINTMSG(TOKEN_LINE(token), 1110, Warning, TOKEN_COLUMN(token)); 02692 TOKEN_VALUE(token) = Tok_Const_Real; 02693 result = convert_const(); 02694 } 02695 else { 02696 CONVERT_DBL_CONST(DOUBLE_PRECISION_TYPE_IDX, 02697 TOKEN_LEN(token), result); 02698 } 02699 # else 02700 CONVERT_DBL_CONST(DOUBLE_PRECISION_TYPE_IDX, 02701 TOKEN_LEN(token), result); 02702 # endif 02703 break; 02704 case Tok_Const_Quad : 02705 CONVERT_REAL_CONST(Real_16, 02706 TOKEN_LEN(token), result); 02707 break; 02708 } 02709 } 02710 else if (TOKEN_VALUE(token) == Tok_Const_Int || 02711 TOKEN_VALUE(token) == Tok_Const_Real || 02712 TOKEN_VALUE(token) == Tok_Const_Quad || 02713 TOKEN_VALUE(token) == Tok_Const_Dbl) { 02714 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 02715 } 02716 02717 EXIT: 02718 02719 TRACE (Func_Exit, "get_operand_digit", NULL); 02720 02721 return (result); 02722 02723 } /* get_operand_digit */ 02724 02725 /******************************************************************************\ 02726 |* *| 02727 |* Description: *| 02728 |* Get_operand_dot is called by the get_token routine to attempt *| 02729 |* recognition of real constants of the form .nnn, and logical constants *| 02730 |* that begin with "." by examining the look ahead *| 02731 |* character and following characters of the input source. *| 02732 |* *| 02733 |* Input parameters: *| 02734 |* la_ch first character of operand token *| 02735 |* *| 02736 |* Output parameters: *| 02737 |* la_ch next character of input source statement *| 02738 |* token token produced by get_operand_dot *| 02739 |* *| 02740 |* Returns: *| 02741 |* TRUE indicates an operand token was produced. *| 02742 |* FALSE indicates that an error was encountered. *| 02743 |* *| 02744 \******************************************************************************/ 02745 02746 static boolean get_operand_dot (void) 02747 02748 { 02749 int attr_idx; 02750 char exponent = BLANK; 02751 int name_idx; 02752 boolean result = TRUE; 02753 la_type save_ch; 02754 int tok_len = 0; 02755 02756 02757 TRACE (Func_Entry, "get_operand_dot", NULL); 02758 02759 # ifdef _DEBUG 02760 if (LA_CH_VALUE != DOT) { 02761 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 02762 "get_operand_dot", "."); 02763 } 02764 # endif 02765 02766 /* check for logical constant or dot-op form operator */ 02767 save_ch = la_ch; 02768 02769 NEXT_LA_CH; 02770 02771 while (LA_CH_CLASS == Ch_Class_Letter && !sig_blank) { 02772 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 02773 NEXT_LA_CH; 02774 } 02775 02776 if (tok_len > MAX_ID_LEN) { 02777 PRINTMSG(TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 02778 tok_len = MAX_ID_LEN; 02779 } 02780 TOKEN_LEN(token) = tok_len; 02781 02782 if (LA_CH_VALUE == DOT && !sig_blank) { 02783 02784 if (EQUAL_STRS(TOKEN_STR(token), "TRUE") || 02785 EQUAL_STRS(TOKEN_STR(token), "FALSE") || 02786 EQUAL_STRS(TOKEN_STR(token), "T") || 02787 EQUAL_STRS(TOKEN_STR(token), "F")) { 02788 02789 TOKEN_VALUE(token) = (TOKEN_STR(token)[0] == 'T') ? Tok_Const_True : 02790 Tok_Const_False; 02791 NEXT_LA_CH; 02792 02793 if (tok_len == 1) { 02794 attr_idx = srch_sym_tbl(TOKEN_STR(token), 02795 TOKEN_LEN(token), 02796 &name_idx); 02797 02798 if (attr_idx == NULL_IDX) { 02799 attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 02800 TOKEN_LEN(token), 02801 &name_idx, 02802 TRUE); 02803 } 02804 02805 if (attr_idx != NULL_IDX) { 02806 02807 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 02808 attr_idx = AT_ATTR_LINK(attr_idx); 02809 } 02810 } 02811 02812 /* Let NOT_VISIBLE items take the standard path */ 02813 02814 if (attr_idx != NULL_IDX && AT_OBJ_CLASS(attr_idx) == Interface) { 02815 02816 /* .T. of .F. is a defined operator so the extension */ 02817 /* is disallowed. */ 02818 02819 reset_lex(TOKEN_BUF_IDX(token), TOKEN_STMT_NUM(token)); 02820 TOKEN_VALUE(token) = Tok_Unknown; 02821 result = FALSE; 02822 goto EXIT; 02823 } 02824 else { 02825 PRINTMSG(TOKEN_LINE(token), 510, Ansi, TOKEN_COLUMN(token), 02826 TOKEN_STR(token)); 02827 } 02828 } 02829 02830 /* check for optional kind-param suffix on logical constant */ 02831 if (LA_CH_VALUE == USCORE) { 02832 NEXT_LA_CH; 02833 02834 tok_len = 0; 02835 02836 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02837 do { 02838 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02839 NEXT_LA_CH; 02840 } 02841 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02842 } 02843 else if (LA_CH_CLASS == Ch_Class_Letter && !sig_blank) { 02844 do { 02845 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02846 NEXT_LA_CH; 02847 } 02848 while (VALID_LA_CH); 02849 } 02850 else { 02851 /* Kind param on literal const must be integer or symbolic name*/ 02852 PRINTMSG (LA_CH_LINE, 89, Error, LA_CH_COLUMN); 02853 result = FALSE; 02854 } 02855 TOKEN_KIND_LEN(token) = tok_len; 02856 } /* if */ 02857 02858 result = convert_const() && result; 02859 02860 } /* if */ 02861 else { /* reset src input buffer and column index to la_ch pos */ 02862 /* this is not an opnd .. let someone else deal with it */ 02863 la_ch = save_ch; 02864 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 02865 result = FALSE; 02866 sig_blank = FALSE; 02867 TOKEN_VALUE(token) = Tok_Unknown; 02868 } 02869 } /* if */ 02870 else { 02871 /* have decimal point in real constant */ 02872 TOKEN_VALUE(token) = Tok_Const_Real; 02873 02874 /* reset src input buffer and column index to la_ch pos */ 02875 la_ch = save_ch; 02876 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 02877 sig_blank = FALSE; 02878 02879 /* add decimal point to constant */ 02880 tok_len = 0; 02881 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02882 NEXT_LA_CH; 02883 02884 /* check for required fractional digits of real constant */ 02885 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02886 do { 02887 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02888 NEXT_LA_CH; 02889 } 02890 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02891 02892 /* check for optional exponent letter in real constant */ 02893 if ((LA_CH_VALUE == 'D' || 02894 LA_CH_VALUE == 'E' || 02895 LA_CH_VALUE == 'Q') && 02896 !sig_blank) { 02897 02898 exponent = LA_CH_VALUE; 02899 02900 switch (LA_CH_VALUE) { 02901 case 'D': 02902 TOKEN_VALUE(token) = Tok_Const_Dbl; 02903 break; 02904 02905 case 'E': 02906 TOKEN_VALUE(token) = Tok_Const_Real; 02907 break; 02908 02909 case 'Q': 02910 # if defined(_QUAD_PRECISION) 02911 TOKEN_VALUE(token) = Tok_Const_Quad; 02912 # else 02913 TOKEN_VALUE(token) = Tok_Const_Dbl; 02914 PRINTMSG(TOKEN_LINE(token), 1348, Caution, 02915 TOKEN_COLUMN(token)); 02916 # endif 02917 break; 02918 } 02919 02920 ADD_TO_CONST_BUF ('E', tok_len); 02921 02922 NEXT_LA_CH; 02923 02924 /* check for optional sign in exponent */ 02925 if ((LA_CH_VALUE == PLUS || LA_CH_VALUE == MINUS) && !sig_blank) { 02926 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02927 NEXT_LA_CH; 02928 } 02929 02930 /* check for required digits of exponent */ 02931 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02932 do { 02933 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 02934 NEXT_LA_CH; 02935 } 02936 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02937 } 02938 else { /* Invalid exponent in real constant */ 02939 PRINTMSG (LA_CH_LINE, 1308, Error, LA_CH_COLUMN); 02940 result = FALSE; 02941 } 02942 02943 /* check that kind-param doesn't follow real const with exponent 'D' */ 02944 02945 if (LA_CH_VALUE == USCORE && 02946 (exponent == 'D' || 02947 exponent == 'Q') && 02948 !sig_blank) { 02949 02950 /* Kind param is invalid on double precision real const form */ 02951 PRINTMSG (TOKEN_LINE(token), 1309, Error, TOKEN_COLUMN(token)); 02952 result = FALSE; 02953 } 02954 } 02955 02956 TOKEN_LEN(token) = tok_len; 02957 const_buf[tok_len] = '\0'; 02958 02959 /* check for optional kind-param suffix on real constant */ 02960 02961 if (LA_CH_VALUE == USCORE && !sig_blank) { 02962 NEXT_LA_CH; 02963 02964 tok_len = 0; 02965 02966 if (LA_CH_CLASS == Ch_Class_Digit && !sig_blank) { 02967 do { 02968 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02969 NEXT_LA_CH; 02970 } 02971 while (LA_CH_CLASS == Ch_Class_Digit && !sig_blank); 02972 } 02973 else if (LA_CH_CLASS == Ch_Class_Letter && !sig_blank) { 02974 do { 02975 ADD_TO_TOKEN_KIND_STR (LA_CH_VALUE, tok_len); 02976 NEXT_LA_CH; 02977 } 02978 while (VALID_LA_CH); 02979 } 02980 else { /* Kind param on literal const must be int or symbolic name*/ 02981 PRINTMSG (LA_CH_LINE, 89, Error, LA_CH_COLUMN); 02982 result = FALSE; 02983 } 02984 02985 if (tok_len > MAX_ID_LEN) { 02986 tok_len = MAX_ID_LEN; 02987 PRINTMSG(LA_CH_LINE, 101, Error, LA_CH_COLUMN); 02988 } 02989 TOKEN_KIND_LEN(token) = tok_len; 02990 TOKEN_KIND_STR(token)[tok_len] = EOS; 02991 } /* if */ 02992 } /* if */ 02993 else { 02994 /* Real constant must contain digits in whole or fractional part */ 02995 PRINTMSG (TOKEN_LINE(token), 95, Error, TOKEN_COLUMN(token)); 02996 result = FALSE; 02997 02998 if (tok_len > MAX_ID_LEN) { 02999 PRINTMSG(TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 03000 tok_len = MAX_ID_LEN; 03001 } 03002 TOKEN_LEN(token) = tok_len; 03003 } 03004 } 03005 03006 if (TOKEN_VALUE(token) == Tok_Const_Real || 03007 TOKEN_VALUE(token) == Tok_Const_Dbl || 03008 TOKEN_VALUE(token) == Tok_Const_Quad) { 03009 03010 CHECK_FOR_FREE_BLANK; 03011 03012 if (result) { 03013 switch (TOKEN_VALUE(token)) { 03014 case Tok_Const_Real : 03015 result = convert_const(); 03016 break; 03017 case Tok_Const_Dbl : 03018 03019 # ifdef _TARGET_OS_MAX 03020 if (! cmd_line_flags.s_default32 && 03021 on_off_flags.enable_double_precision) { 03022 PRINTMSG(TOKEN_LINE(token), 1110, Warning, 03023 TOKEN_COLUMN(token)); 03024 TOKEN_VALUE(token) = Tok_Const_Real; 03025 result = convert_const(); 03026 } 03027 else { 03028 CONVERT_DBL_CONST(DOUBLE_PRECISION_TYPE_IDX, 03029 TOKEN_LEN(token), result); 03030 } 03031 # else 03032 CONVERT_DBL_CONST(DOUBLE_PRECISION_TYPE_IDX, 03033 TOKEN_LEN(token), result); 03034 # endif 03035 break; 03036 case Tok_Const_Quad : 03037 CONVERT_REAL_CONST(Real_16, 03038 TOKEN_LEN(token), result); 03039 break; 03040 } 03041 } 03042 else { 03043 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03044 } 03045 } 03046 03047 EXIT: 03048 03049 TRACE (Func_Exit, "get_operand_dot", NULL); 03050 03051 return (result); 03052 03053 } /* get_operand_dot */ 03054 03055 /******************************************************************************\ 03056 |* *| 03057 |* Description: *| 03058 |* Get_operand_letter is called by the get_token routine to attempt *| 03059 |* recognition of identifiers, boolean octal, boolean hex, boolean *| 03060 |* hollerith, and non-default kind character literal constant forms by *| 03061 |* examining the look ahead character and following characters of the *| 03062 |* input source. *| 03063 |* *| 03064 |* Input parameters: *| 03065 |* la_ch first character of operand token *| 03066 |* *| 03067 |* Output parameters: *| 03068 |* la_ch next character of input source statement *| 03069 |* token token produced by get_operand_letter *| 03070 |* *| 03071 |* Returns: *| 03072 |* TRUE indicates an operand token was produced. *| 03073 |* FALSE indicates that an error was encountered. *| 03074 |* *| 03075 \******************************************************************************/ 03076 03077 static boolean get_operand_letter (void) 03078 03079 { 03080 char delim; 03081 boolean had_zero = FALSE; 03082 char prefix; 03083 boolean result = TRUE; 03084 int tok_len = 0; 03085 03086 03087 TRACE (Func_Entry, "get_operand_letter", NULL); 03088 03089 # ifdef _DEBUG 03090 if (LA_CH_CLASS != Ch_Class_Letter) { 03091 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 03092 "get_operand_letter", "letter"); 03093 } 03094 # endif 03095 03096 prefix = LA_CH_VALUE; /* remember 1st */ 03097 03098 do { 03099 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 03100 NEXT_LA_CH; 03101 } 03102 while (VALID_LA_CH); 03103 03104 if (tok_len > MAX_ID_LEN) { 03105 PRINTMSG(TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 03106 tok_len = MAX_ID_LEN; 03107 } 03108 TOKEN_LEN(token) = tok_len; 03109 03110 if ((LA_CH_VALUE == QUOTE || LA_CH_VALUE == DBL_QUOTE) && !sig_blank) { 03111 if (tok_len == 1) { 03112 03113 if (prefix == 'B' || prefix == 'O' || prefix == 'Z' || prefix == 'X') { 03114 03115 if (prefix == 'X') { /* Boolean constants are non-standard */ 03116 PRINTMSG (TOKEN_LINE(token), 90, Ansi, TOKEN_COLUMN(token)); 03117 TOKEN_VALUE(token) = Tok_Const_Boolean; 03118 } 03119 else { 03120 TOKEN_VALUE(token) = Tok_Const_Boz; 03121 03122 if (stmt_type != Data_Stmt) { 03123 PRINTMSG (TOKEN_LINE(token), 771, Ansi, TOKEN_COLUMN(token)); 03124 } 03125 } 03126 03127 strcpy (TOKEN_KIND_STR(token), TOKEN_STR(token)); 03128 TOKEN_KIND_LEN(token) = TOKEN_LEN(token); 03129 03130 delim = LA_CH_VALUE; 03131 03132 NEXT_LA_CH; 03133 tok_len = 0; 03134 03135 /* skip leading zeros */ 03136 while (LA_CH_VALUE != delim && 03137 LA_CH_VALUE != EOS && 03138 (LA_CH_VALUE == ZERO || 03139 LA_CH_VALUE == BLANK || 03140 LA_CH_VALUE == TAB)) { 03141 03142 if (LA_CH_VALUE == ZERO) { 03143 had_zero = TRUE; 03144 } 03145 NEXT_LA_CH; 03146 } 03147 03148 while (LA_CH_VALUE != delim && LA_CH_VALUE != EOS) { 03149 if (LA_CH_VALUE != BLANK && LA_CH_VALUE != TAB) { 03150 ADD_TO_CONST_BUF (LA_CH_VALUE, tok_len); 03151 } 03152 NEXT_LA_CH; 03153 } 03154 03155 if (tok_len == 0 && had_zero) { 03156 ADD_TO_CONST_BUF (ZERO, tok_len); 03157 } 03158 03159 const_buf[tok_len] = '\0'; 03160 TOKEN_LEN(token) = tok_len; 03161 03162 if (LA_CH_VALUE == EOS) { /* Token is missing trailing delimiter */ 03163 PRINTMSG(TOKEN_LINE(token), 83, Error,TOKEN_COLUMN(token),delim); 03164 result = FALSE; 03165 } 03166 else { 03167 if (prefix == 'B') { /* validate length of binary constant */ 03168 03169 if (tok_len > MAX_BIN_CONST_LEN || tok_len == 0) { 03170 03171 /* Binary constant length is invalid */ 03172 03173 PRINTMSG(TOKEN_LINE(token), 91, Error, 03174 TOKEN_COLUMN(token), tok_len, MAX_BIN_CONST_LEN); 03175 result = FALSE; 03176 } 03177 03178 /* validate that all digits of token are binary digits */ 03179 tok_len = 0; 03180 03181 while (IS_BIN_DIGIT(const_buf[tok_len])) { 03182 tok_len++; 03183 } 03184 03185 if (const_buf[tok_len] != EOS) { 03186 PRINTMSG (TOKEN_LINE(token), 422, Error, 03187 TOKEN_COLUMN(token), const_buf[tok_len]); 03188 result = FALSE; 03189 } 03190 03191 if (result) { 03192 convert_binary_literal(TRUE); 03193 } 03194 else { 03195 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03196 } 03197 } 03198 else if (prefix == 'O') { 03199 03200 /* validate length of octal constant */ 03201 03202 if (tok_len > MAX_OCT_CONST_LEN || tok_len == 0) { 03203 03204 /* Octal constant length is invalid */ 03205 03206 PRINTMSG(TOKEN_LINE(token), 91, Error, 03207 TOKEN_COLUMN(token), tok_len, MAX_OCT_CONST_LEN); 03208 result = FALSE; 03209 } 03210 else if (tok_len == MAX_OCT_CONST_LEN) { 03211 03212 if (const_buf[0] < '0' || const_buf[0] > '1') { 03213 /* Octal constant value is out of range */ 03214 03215 PRINTMSG(TOKEN_LINE(token), 92, Error, 03216 TOKEN_COLUMN(token)); 03217 result = FALSE; 03218 } 03219 } 03220 03221 /* validate that all digits of token are octal digits */ 03222 tok_len = 0; 03223 03224 while (IS_OCT_DIGIT(const_buf[tok_len])) { 03225 tok_len++; 03226 } 03227 03228 if (const_buf[tok_len] != EOS) { 03229 PRINTMSG(TOKEN_LINE(token), 93, Error, TOKEN_COLUMN(token), 03230 const_buf[tok_len]); 03231 result = FALSE; 03232 } 03233 03234 if (result) { 03235 convert_octal_literal(TRUE); 03236 } 03237 else { 03238 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03239 } 03240 } 03241 else if (prefix == 'Z') { 03242 03243 /* validate length of hex constant */ 03244 03245 if (tok_len > MAX_HEX_CONST_LEN || tok_len == 0) { 03246 PRINTMSG(TOKEN_LINE(token), 91, Error, 03247 TOKEN_COLUMN(token), tok_len, MAX_HEX_CONST_LEN); 03248 result = FALSE; 03249 } 03250 03251 /* validate that all digits of token are hex digits */ 03252 tok_len = 0; 03253 03254 while (isxdigit(const_buf[tok_len])) { 03255 tok_len++; 03256 } 03257 03258 if (const_buf[tok_len] != EOS) { 03259 PRINTMSG (TOKEN_LINE(token), 423, Error, 03260 TOKEN_COLUMN(token), const_buf[tok_len]); 03261 result = FALSE; 03262 } 03263 03264 if (result) { 03265 convert_hex_literal(TRUE); 03266 } 03267 else { 03268 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03269 } 03270 } 03271 else { /* prefix = X */ 03272 03273 if (const_buf[0] == PLUS || const_buf[0] == MINUS) { 03274 03275 /* validate length of sign plus hex constant */ 03276 03277 if (--tok_len > MAX_HEX_CONST_LEN || tok_len == 0) { 03278 03279 PRINTMSG(TOKEN_LINE(token), 91, Error, 03280 TOKEN_COLUMN(token), tok_len, 03281 MAX_HEX_CONST_LEN); 03282 result = FALSE; 03283 } 03284 tok_len = 1; 03285 } 03286 else { 03287 03288 if (tok_len > MAX_HEX_CONST_LEN || tok_len == 0) { 03289 PRINTMSG(TOKEN_LINE(token), 91, Error, 03290 TOKEN_COLUMN(token), tok_len, 03291 MAX_HEX_CONST_LEN); 03292 result = FALSE; 03293 } 03294 tok_len = 0; 03295 } 03296 03297 /* validate that all digits of token are hex digits */ 03298 03299 while (isxdigit(const_buf[tok_len])) { 03300 tok_len++; 03301 } 03302 03303 if (const_buf[tok_len] != EOS) { 03304 PRINTMSG (TOKEN_LINE(token), 423, Error, 03305 TOKEN_COLUMN(token), const_buf[tok_len]); 03306 result = FALSE; 03307 } 03308 03309 if (result) { 03310 convert_hex_literal(FALSE); 03311 } 03312 else { 03313 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03314 } 03315 } 03316 03317 NEXT_LA_CH; 03318 } 03319 } 03320 else { 03321 TOKEN_VALUE(token) = Tok_Id; 03322 } 03323 } /* if */ 03324 else if (TOKEN_STR(token)[tok_len-1] == USCORE) { /* kind param */ 03325 03326 TOKEN_VALUE(token) = Tok_Const_Char; 03327 03328 if (--tok_len > MAX_ID_LEN) { 03329 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 03330 result = FALSE; 03331 tok_len = MAX_ID_LEN; 03332 } 03333 TOKEN_STR(token)[tok_len] = EOS; /* remove '_' */ 03334 03335 strcpy (TOKEN_KIND_STR(token), TOKEN_STR(token)); 03336 TOKEN_KIND_LEN(token) = TOKEN_LEN(token) - 1; 03337 03338 delim = LA_CH_VALUE; 03339 NEXT_LA_CH; 03340 03341 result = convert_const() && result; 03342 03343 TOKEN_CONST_TBL_IDX(token) = put_char_const_in_tbl ('\0', &tok_len); 03344 03345 TOKEN_LEN(token) = tok_len; 03346 03347 if (LA_CH_VALUE != delim) { 03348 PRINTMSG (TOKEN_LINE(token), 83, Error, TOKEN_COLUMN(token), delim); 03349 result = FALSE; 03350 } 03351 else { 03352 NEXT_LA_CH; 03353 } 03354 } /* else if */ 03355 else { 03356 TOKEN_VALUE(token) = Tok_Id; 03357 03358 if (tok_len > MAX_ID_LEN) { /* Id len exceeds max of 31 characters */ 03359 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 03360 tok_len = MAX_ID_LEN; 03361 } 03362 } 03363 } /* if */ 03364 else { 03365 TOKEN_VALUE(token) = Tok_Id; 03366 03367 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters */ 03368 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 03369 tok_len = MAX_ID_LEN; 03370 } 03371 } 03372 03373 TRACE (Func_Exit, "get_operand_letter", NULL); 03374 03375 return (result); 03376 03377 } /* get_operand_letter */ 03378 03379 /******************************************************************************\ 03380 |* *| 03381 |* Description: *| 03382 |* Get_operand_quote is called by the get_token routine to attempt *| 03383 |* recognition of character literal constants of the form '...' or "...",*| 03384 |* and boolean hollerith constants of the form '...'H, "..."H, '...'L, *| 03385 |* "..."L, '...'R, or "..."R by examining the look ahead character and *| 03386 |* following characters of the input source. *| 03387 |* *| 03388 |* Input parameters: *| 03389 |* la_ch first character of operand token *| 03390 |* *| 03391 |* Output parameters: *| 03392 |* la_ch next character of input source statement *| 03393 |* token token produced by get_operand_quote *| 03394 |* *| 03395 |* Returns: *| 03396 |* TRUE indicates an operand token was produced. *| 03397 |* FALSE indicates that an error was encountered. *| 03398 |* *| 03399 \******************************************************************************/ 03400 03401 static boolean get_operand_quote (void) 03402 03403 { 03404 int char_len; 03405 char *chptr; 03406 char delim; 03407 boolean had_zero = FALSE; 03408 int i; 03409 boolean result = TRUE; 03410 int shift; 03411 int tok_len = 0; 03412 03413 03414 TRACE (Func_Entry, "get_operand_quote", NULL); 03415 03416 # ifdef _DEBUG 03417 if (LA_CH_VALUE != QUOTE && LA_CH_VALUE != DBL_QUOTE) { 03418 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 03419 "get_operand_quote", "quote or double quote"); 03420 } 03421 # endif 03422 03423 delim = LA_CH_VALUE; 03424 NEXT_LA_CH; 03425 TOKEN_VALUE(token) = Tok_Const_Char; 03426 03427 /* assume 'H' hollerith for now */ 03428 03429 TOKEN_CONST_TBL_IDX(token) = put_char_const_in_tbl ('H', &tok_len); 03430 03431 if (LA_CH_VALUE != delim) { 03432 PRINTMSG (TOKEN_LINE(token), 83, Error, TOKEN_COLUMN(token), delim); 03433 result = FALSE; 03434 } 03435 else { 03436 NEXT_LA_CH; 03437 } 03438 03439 TOKEN_LEN(token) = tok_len; 03440 03441 /* check for hollerith suffix letters */ 03442 if ((LA_CH_VALUE == 'H' || LA_CH_VALUE == 'L' || LA_CH_VALUE == 'R') && 03443 !sig_blank) { 03444 03445 if (LA_CH_VALUE == 'L') { /* replace trailing blanks with nulls */ 03446 chptr = (char *)&CN_CONST(TOKEN_CONST_TBL_IDX(token)); 03447 03448 while (tok_len % TARGET_CHARS_PER_WORD != 0) { 03449 chptr[tok_len] = '\0'; 03450 tok_len++; 03451 } 03452 } 03453 else if (LA_CH_VALUE == 'R') { /* shift const to be right justified */ 03454 chptr = (char *)&CN_CONST(TOKEN_CONST_TBL_IDX(token)); 03455 shift = (TARGET_CHARS_PER_WORD - (tok_len % TARGET_CHARS_PER_WORD)) % 03456 TARGET_CHARS_PER_WORD; 03457 03458 if (shift) { 03459 while (--tok_len >= 0) { 03460 chptr[tok_len + shift] = chptr[tok_len]; 03461 } 03462 03463 tok_len = shift; 03464 while (--tok_len >= 0) { 03465 chptr[tok_len] = '\0'; 03466 } 03467 } 03468 } 03469 03470 TOKEN_VALUE(token) = Tok_Const_Hollerith; 03471 03472 /* Hollerith constant form is non-standard */ 03473 03474 PRINTMSG(TOKEN_LINE(token), 96, Ansi, TOKEN_COLUMN(token)); 03475 03476 if (TOKEN_LEN(token) > TARGET_CHARS_PER_WORD && LA_CH_VALUE == 'R') { 03477 03478 /* Hollerith constant must be 8 (4 on sparc) */ 03479 /* characters or less in "R" form */ 03480 03481 PRINTMSG(TOKEN_LINE(token), 94, Error, TOKEN_COLUMN(token), 03482 TARGET_CHARS_PER_WORD); 03483 result = FALSE; 03484 } 03485 03486 TOKEN_KIND_STR(token)[0] = LA_CH_VALUE; 03487 TOKEN_KIND_STR(token)[1] = EOS; 03488 TOKEN_KIND_LEN(token) = 1; 03489 03490 # ifdef _TARGET_LITTLE_ENDIAN 03491 if (TOKEN_KIND_STR(token)[0] != 'R') { 03492 CN_HOLLERITH_ENDIAN(TOKEN_CONST_TBL_IDX(token)) = TRUE; 03493 } 03494 # endif 03495 03496 switch(TOKEN_KIND_STR(token)[0]) { 03497 case 'H': 03498 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = H_Hollerith; 03499 break; 03500 03501 case 'L': 03502 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = L_Hollerith; 03503 break; 03504 03505 case 'R': 03506 CN_HOLLERITH_TYPE(TOKEN_CONST_TBL_IDX(token)) = R_Hollerith; 03507 break; 03508 03509 } 03510 03511 NEXT_LA_CH; 03512 } 03513 else if (LA_CH_VALUE == 'X' && ! sig_blank) { 03514 03515 NEXT_LA_CH; 03516 03517 /* this is a hex constant */ 03518 03519 PRINTMSG (TOKEN_LINE(token), 90, Ansi, TOKEN_COLUMN(token)); 03520 TOKEN_VALUE(token) = Tok_Const_Boolean; 03521 03522 /* put the character constant into the const_buf */ 03523 03524 chptr = (char *)&CN_CONST(TOKEN_CONST_TBL_IDX(token)); 03525 03526 char_len = tok_len; 03527 03528 i = 0; 03529 while (i < char_len && 03530 (chptr[i] == ZERO || 03531 chptr[i] == BLANK || 03532 chptr[i] == TAB)) { 03533 03534 if (chptr[i] == ZERO) { 03535 had_zero = TRUE; 03536 } 03537 03538 i++; 03539 } 03540 03541 tok_len = 0; 03542 03543 while (i < char_len) { 03544 if (chptr[i] != BLANK && 03545 chptr[i] != TAB) { 03546 ADD_TO_CONST_BUF (chptr[i], tok_len); 03547 } 03548 i++; 03549 } 03550 03551 if (tok_len == 0 && had_zero) { 03552 ADD_TO_CONST_BUF (ZERO, tok_len); 03553 } 03554 03555 const_buf[tok_len] = '\0'; 03556 TOKEN_LEN(token) = tok_len; 03557 03558 if (const_buf[0] == PLUS || const_buf[0] == MINUS) { 03559 03560 /* validate length of sign plus hex constant */ 03561 03562 if (--tok_len > MAX_HEX_CONST_LEN || tok_len == 0) { 03563 03564 PRINTMSG(TOKEN_LINE(token), 91, Error, 03565 TOKEN_COLUMN(token), tok_len, 03566 MAX_HEX_CONST_LEN); 03567 result = FALSE; 03568 } 03569 tok_len = 1; 03570 } 03571 else { 03572 03573 if (tok_len > MAX_HEX_CONST_LEN || tok_len == 0) { 03574 PRINTMSG(TOKEN_LINE(token), 91, Error, 03575 TOKEN_COLUMN(token), tok_len, 03576 MAX_HEX_CONST_LEN); 03577 result = FALSE; 03578 } 03579 tok_len = 0; 03580 } 03581 03582 /* validate that all digits of token are hex digits */ 03583 03584 while (isxdigit(const_buf[tok_len])) { 03585 tok_len++; 03586 } 03587 03588 if (const_buf[tok_len] != EOS) { 03589 PRINTMSG (TOKEN_LINE(token), 423, Error, 03590 TOKEN_COLUMN(token), const_buf[tok_len]); 03591 result = FALSE; 03592 } 03593 03594 if (result) { 03595 convert_hex_literal(FALSE); 03596 } 03597 else { 03598 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03599 } 03600 } 03601 else if (LA_CH_VALUE == 'O' && ! sig_blank) { 03602 03603 NEXT_LA_CH; 03604 03605 /* this is an octal constant */ 03606 03607 PRINTMSG (TOKEN_LINE(token), 90, Ansi, TOKEN_COLUMN(token)); 03608 TOKEN_VALUE(token) = Tok_Const_Boolean; 03609 03610 /* put the character constant into the const_buf */ 03611 03612 chptr = (char *)&CN_CONST(TOKEN_CONST_TBL_IDX(token)); 03613 03614 char_len = tok_len; 03615 03616 i = 0; 03617 while (i < char_len && 03618 (chptr[i] == ZERO || 03619 chptr[i] == BLANK || 03620 chptr[i] == TAB)) { 03621 03622 if (chptr[i] == ZERO) { 03623 had_zero = TRUE; 03624 } 03625 03626 i++; 03627 } 03628 03629 tok_len = 0; 03630 03631 while (i < char_len) { 03632 if (chptr[i] != BLANK && 03633 chptr[i] != TAB) { 03634 ADD_TO_CONST_BUF (chptr[i], tok_len); 03635 } 03636 i++; 03637 } 03638 03639 if (tok_len == 0 && had_zero) { 03640 ADD_TO_CONST_BUF (ZERO, tok_len); 03641 } 03642 03643 const_buf[tok_len] = '\0'; 03644 TOKEN_LEN(token) = tok_len; 03645 03646 if (tok_len > MAX_OCT_CONST_LEN) { 03647 PRINTMSG(TOKEN_LINE(token), 91, Error, TOKEN_COLUMN(token), 03648 tok_len, MAX_OCT_CONST_LEN); 03649 } 03650 else if (tok_len == MAX_OCT_CONST_LEN) { 03651 03652 if (const_buf[0] < '0' || const_buf[0] > '1') { 03653 /* The value exceeds the range. */ 03654 03655 PRINTMSG (TOKEN_LINE(token), 92, Error, TOKEN_COLUMN(token)); 03656 result = FALSE; 03657 } 03658 } 03659 03660 tok_len = 0; 03661 03662 /* validate that all digits of token are octal digits */ 03663 03664 while (IS_OCT_DIGIT(const_buf[tok_len])) { 03665 tok_len++; 03666 } 03667 03668 if (const_buf[tok_len] != EOS) { 03669 PRINTMSG (TOKEN_LINE(token), 93, Error, 03670 TOKEN_COLUMN(token), const_buf[tok_len]); 03671 result = FALSE; 03672 } 03673 03674 if (result) { 03675 convert_octal_literal(FALSE); 03676 } 03677 else { 03678 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 03679 } 03680 } 03681 else { 03682 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 03683 TYP_TYPE(TYP_WORK_IDX) = Character; 03684 TYP_LINEAR(TYP_WORK_IDX) = CHARACTER_DEFAULT_TYPE; 03685 TYP_CHAR_CLASS(TYP_WORK_IDX) = Const_Len_Char; 03686 TYP_FLD(TYP_WORK_IDX) = CN_Tbl_Idx; 03687 TYP_IDX(TYP_WORK_IDX) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, tok_len); 03688 03689 CN_TYPE_IDX(TOKEN_CONST_TBL_IDX(token)) = ntr_type_tbl(); 03690 } 03691 03692 TRACE (Func_Exit, "get_operand_quote", NULL); 03693 03694 return (result); 03695 03696 } /* get_operand_quote */ 03697 03698 /******************************************************************************\ 03699 |* *| 03700 |* Description: *| 03701 |* Get_operator is called by the get_token routine to attempt recognition*| 03702 |* of an operator token using the look ahead character and following *| 03703 |* characters of the input source. *| 03704 |* *| 03705 |* Input parameters: *| 03706 |* la_ch first character of operator token *| 03707 |* *| 03708 |* Output parameters: *| 03709 |* la_ch next character of input source statement *| 03710 |* token token created by get_operator *| 03711 |* *| 03712 |* Returns: *| 03713 |* TRUE indicates an operator token was produced. *| 03714 |* FALSE indicates that an error was encountered. *| 03715 |* *| 03716 \******************************************************************************/ 03717 03718 static boolean get_operator (void) 03719 03720 { 03721 int buf_idx; 03722 char op_ch; 03723 boolean result = TRUE; 03724 int stmt_num; 03725 03726 03727 TRACE (Func_Entry, "get_operator", NULL); 03728 03729 # ifdef _DEBUG 03730 if (LA_CH_CLASS != Ch_Class_Symbol) { 03731 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 03732 "get_operator", "symbol"); 03733 } 03734 # endif 03735 03736 op_ch = LA_CH_VALUE; 03737 buf_idx = LA_CH_BUF_IDX; 03738 stmt_num = LA_CH_STMT_NUM; 03739 TOKEN_STR(token)[0] = op_ch; 03740 03741 if (op_ch != PLUS && 03742 op_ch != MINUS && 03743 op_ch != STAR && 03744 op_ch != SLASH && 03745 op_ch != EQUAL && 03746 op_ch != GT && 03747 op_ch != LT && 03748 op_ch != DOT && 03749 op_ch != PERCENT) { 03750 03751 result = FALSE; 03752 TOKEN_VALUE(token) = Tok_Unknown; 03753 } 03754 else { 03755 03756 NEXT_LA_CH; /* op may be multi-character */ 03757 03758 switch (op_ch) { 03759 case PLUS : 03760 TOKEN_VALUE(token) = Tok_Op_Add; 03761 TOKEN_LEN(token) = 1; 03762 break; 03763 03764 case MINUS : 03765 TOKEN_VALUE(token) = Tok_Op_Sub; 03766 TOKEN_LEN(token) = 1; 03767 break; 03768 03769 case STAR : 03770 if (LA_CH_VALUE == STAR && !sig_blank) { 03771 TOKEN_VALUE(token) = Tok_Op_Power; 03772 TOKEN_STR(token)[1] = STAR; 03773 TOKEN_LEN(token) = 2; 03774 NEXT_LA_CH; 03775 } 03776 else { 03777 TOKEN_VALUE(token) = Tok_Op_Mult; 03778 TOKEN_LEN(token) = 1; 03779 } 03780 break; 03781 03782 case SLASH : 03783 if (LA_CH_VALUE == EQUAL && !sig_blank) { 03784 TOKEN_VALUE(token) = Tok_Op_Ne; 03785 TOKEN_STR(token)[1] = EQUAL; 03786 TOKEN_LEN(token) = 2; 03787 NEXT_LA_CH; 03788 } 03789 else if (LA_CH_VALUE == SLASH && !sig_blank) { 03790 TOKEN_VALUE(token) = Tok_Op_Concat; 03791 TOKEN_STR(token)[1] = SLASH; 03792 TOKEN_LEN(token) = 2; 03793 NEXT_LA_CH; 03794 } 03795 else if (LA_CH_VALUE == RPAREN && !sig_blank) { 03796 result = FALSE; 03797 reset_lex(buf_idx,stmt_num); 03798 TOKEN_VALUE(token) = Tok_Unknown; 03799 } 03800 else { 03801 TOKEN_VALUE(token) = Tok_Op_Div; 03802 TOKEN_LEN(token) = 1; 03803 } 03804 break; 03805 03806 case EQUAL : 03807 if (LA_CH_VALUE == EQUAL && !sig_blank) { 03808 TOKEN_VALUE(token) = Tok_Op_Eq; 03809 TOKEN_STR(token)[1] = EQUAL; 03810 TOKEN_LEN(token) = 2; 03811 NEXT_LA_CH; 03812 } 03813 else if (LA_CH_VALUE == GT && !sig_blank) { 03814 TOKEN_VALUE(token) = Tok_Op_Ptr_Assign; 03815 TOKEN_STR(token)[1] = GT; 03816 TOKEN_LEN(token) = 2; 03817 NEXT_LA_CH; 03818 } 03819 else { 03820 TOKEN_VALUE(token) = Tok_Op_Assign; 03821 TOKEN_LEN(token) = 1; 03822 } 03823 break; 03824 03825 case GT : 03826 if (LA_CH_VALUE == EQUAL && !sig_blank) { 03827 TOKEN_VALUE(token) = Tok_Op_Ge; 03828 TOKEN_STR(token)[1] = EQUAL; 03829 TOKEN_LEN(token) = 2; 03830 NEXT_LA_CH; 03831 } 03832 else { 03833 TOKEN_VALUE(token) = Tok_Op_Gt; 03834 TOKEN_LEN(token) = 1; 03835 } 03836 break; 03837 03838 case LT : 03839 if (LA_CH_VALUE == EQUAL && !sig_blank) { 03840 TOKEN_VALUE(token) = Tok_Op_Le; 03841 TOKEN_STR(token)[1] = EQUAL; 03842 TOKEN_LEN(token) = 2; 03843 NEXT_LA_CH; 03844 } 03845 else if (LA_CH_VALUE == GT && 03846 !sig_blank) { 03847 03848 TOKEN_VALUE(token) = Tok_Op_Lg; 03849 TOKEN_STR(token)[1] = GT; 03850 TOKEN_LEN(token) = 2; 03851 NEXT_LA_CH; 03852 } 03853 else { 03854 TOKEN_VALUE(token) = Tok_Op_Lt; 03855 TOKEN_LEN(token) = 1; 03856 } 03857 break; 03858 03859 case DOT : 03860 03861 /* 03862 if (LA_CH_CLASS == Ch_Class_Digit) 03863 */ 03864 if (LA_CH_CLASS != Ch_Class_Letter || 03865 sig_blank) { 03866 result = FALSE; 03867 reset_lex(buf_idx, stmt_num); 03868 } 03869 else { 03870 result = get_operator_dot (); 03871 } 03872 break; 03873 03874 case PERCENT : 03875 TOKEN_VALUE(token) = Tok_Op_Deref; 03876 TOKEN_LEN(token) = 1; 03877 break; 03878 03879 default : 03880 TOKEN_VALUE(token) = Tok_Unknown; 03881 result = FALSE; 03882 TOKEN_LEN(token) = 1; 03883 break; 03884 } /* switch */ 03885 } 03886 03887 TRACE (Func_Exit, "get_operator", NULL); 03888 03889 return (result); 03890 03891 } /* get_operator */ 03892 03893 /******************************************************************************\ 03894 |* *| 03895 |* Description: *| 03896 |* Get_operator_dot is called by the get_operator routine to recognize *| 03897 |* relational operators, logical operators, and defined operators by *| 03898 |* matching the look ahead character and following characters of class *| 03899 |* Ch_Class_Letter with entries in the dot_op table. The operator must *| 03900 |* be delimited with a trailing "." *| 03901 |* *| 03902 |* Input parameters: *| 03903 |* la_ch first character of operator token *| 03904 |* *| 03905 |* Output parameters: *| 03906 |* la_ch next character of input source statement *| 03907 |* token token produced by get_operator_dot *| 03908 |* *| 03909 |* Returns: *| 03910 |* TRUE indicates a dot operator token was produced. *| 03911 |* FALSE indicates that an error was encountered. *| 03912 |* *| 03913 \******************************************************************************/ 03914 03915 static boolean get_operator_dot (void) 03916 03917 { 03918 int attr_idx; 03919 int beg_idx; 03920 int i; 03921 int letter_idx; 03922 int lim_idx; 03923 int name_idx; 03924 boolean result = TRUE; 03925 int tok_len = 0; 03926 03927 03928 TRACE (Func_Entry, "get_operator_dot", NULL); 03929 03930 /* This is only called if LA_CH_CLASS is Ch_Class_Letter */ 03931 03932 while (LA_CH_CLASS == Ch_Class_Letter && !sig_blank) { 03933 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 03934 NEXT_LA_CH; 03935 } 03936 03937 if (tok_len > MAX_ID_LEN) { 03938 /* Defined operator exceeds maximum length of 31 characters */ 03939 PRINTMSG (LA_CH_LINE, 65, Error, LA_CH_COLUMN); 03940 tok_len = MAX_ID_LEN; 03941 TOKEN_LEN(token) = tok_len; 03942 /* call this a user defined opr */ 03943 TOKEN_VALUE(token) = Tok_Op_Defined; 03944 03945 if (LA_CH_VALUE == DOT && !sig_blank) { 03946 NEXT_LA_CH; 03947 } 03948 else { 03949 PRINTMSG (LA_CH_LINE, 66, Error, LA_CH_COLUMN); 03950 } 03951 } 03952 else if (LA_CH_VALUE == DOT && !sig_blank) { 03953 03954 /* check for any dot ops starting with first char of token */ 03955 letter_idx = TOKEN_STR(token)[0] - 'A'; 03956 03957 beg_idx = dot_op_idx[letter_idx]; 03958 lim_idx = dot_op_idx[letter_idx+1]; 03959 03960 /* compare token string to dot_op entries */ 03961 while (beg_idx < lim_idx) { 03962 if (dot_op_len[beg_idx] == tok_len) { 03963 if (strncmp(TOKEN_STR(token), 03964 dot_op[beg_idx].name, 03965 tok_len) == IDENTICAL) { 03966 03967 TOKEN_VALUE(token) = dot_op[beg_idx].value; 03968 03969 break; 03970 } 03971 } 03972 beg_idx++; 03973 } 03974 03975 /* operator must be user defined */ 03976 if (beg_idx == lim_idx) { 03977 TOKEN_VALUE(token) = Tok_Op_Defined; 03978 } 03979 03980 for (i = 0; i < tok_len; i++) { 03981 TOKEN_STR(token)[i] = tolower(TOKEN_STR(token)[i]); 03982 } 03983 03984 switch (TOKEN_VALUE(token)) { 03985 case Tok_Op_Neqv : 03986 03987 if (tok_len == 3 || tok_len == 1) { 03988 03989 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 03990 &name_idx); 03991 03992 if (attr_idx == NULL_IDX) { 03993 attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 03994 TOKEN_LEN(token), 03995 &name_idx, 03996 TRUE); 03997 } 03998 03999 if (attr_idx != NULL_IDX) { 04000 04001 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 04002 attr_idx = AT_ATTR_LINK(attr_idx); 04003 } 04004 } 04005 04006 if (attr_idx == NULL_IDX && 04007 SH_STMT_TYPE(curr_stmt_sh_idx) == Interface_Stmt) { 04008 TOKEN_VALUE(token) = Tok_Op_Defined; 04009 } 04010 04011 else if (attr_idx != NULL_IDX && 04012 AT_OBJ_CLASS(attr_idx) == Interface) { 04013 TOKEN_VALUE(token) = Tok_Op_Defined; 04014 } 04015 else { 04016 PRINTMSG(TOKEN_LINE(token), 317, Ansi, TOKEN_COLUMN(token), 04017 TOKEN_STR(token)); 04018 } 04019 } 04020 break; 04021 04022 case Tok_Const_True : 04023 case Tok_Const_False : 04024 04025 if (tok_len == 1) { 04026 04027 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 04028 &name_idx); 04029 04030 if (attr_idx == NULL_IDX) { 04031 attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 04032 TOKEN_LEN(token), 04033 &name_idx, 04034 TRUE); 04035 } 04036 04037 if (attr_idx != NULL_IDX) { 04038 04039 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 04040 attr_idx = AT_ATTR_LINK(attr_idx); 04041 } 04042 } 04043 04044 if (attr_idx == NULL_IDX && 04045 SH_STMT_TYPE(curr_stmt_sh_idx) == Interface_Stmt) { 04046 TOKEN_VALUE(token) = Tok_Op_Defined; 04047 } 04048 else if (attr_idx != NULL_IDX && 04049 AT_OBJ_CLASS(attr_idx) == Interface) { 04050 TOKEN_VALUE(token) = Tok_Op_Defined; 04051 } 04052 } 04053 04054 break; 04055 04056 case Tok_Op_And : 04057 case Tok_Op_Not : 04058 case Tok_Op_Or : 04059 04060 if (tok_len == 1) { 04061 04062 attr_idx = srch_sym_tbl(TOKEN_STR(token), TOKEN_LEN(token), 04063 &name_idx); 04064 04065 if (attr_idx == NULL_IDX) { 04066 attr_idx = srch_host_sym_tbl(TOKEN_STR(token), 04067 TOKEN_LEN(token), 04068 &name_idx, 04069 TRUE); 04070 } 04071 04072 if (attr_idx != NULL_IDX) { 04073 04074 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 04075 attr_idx = AT_ATTR_LINK(attr_idx); 04076 } 04077 } 04078 04079 if (attr_idx == NULL_IDX && 04080 SH_STMT_TYPE(curr_stmt_sh_idx) == Interface_Stmt) { 04081 TOKEN_VALUE(token) = Tok_Op_Defined; 04082 } 04083 else if (attr_idx != NULL_IDX && 04084 AT_OBJ_CLASS(attr_idx) == Interface) { 04085 TOKEN_VALUE(token) = Tok_Op_Defined; 04086 } 04087 else { 04088 PRINTMSG(TOKEN_LINE(token), 317, Ansi, TOKEN_COLUMN(token), 04089 TOKEN_STR(token)); 04090 } 04091 } 04092 04093 break; 04094 04095 } 04096 NEXT_LA_CH; 04097 } 04098 else { /* Defined operator is missing "." delimiter */ 04099 PRINTMSG (LA_CH_LINE, 66, Error, LA_CH_COLUMN); 04100 result = FALSE; 04101 } 04102 TOKEN_LEN(token) = tok_len; 04103 04104 TRACE (Func_Exit, "get_operator_dot", NULL); 04105 04106 return (result); 04107 04108 } /* get_operator_dot */ 04109 04110 /******************************************************************************\ 04111 |* *| 04112 |* Description: *| 04113 |* Get_program_str is called by the get_token routine to attempt *| 04114 |* recognition of the optional string in a program statement by using *| 04115 |* the look ahead character and following characters of the input source.*| 04116 |* This is a special case, the only thing cft90 does is to check to make *| 04117 |* sure there is only one (....) group. It then gets to EOS. Cft90 *| 04118 |* will do no more with this string, because it was used for CTSS. *| 04119 |* *| 04120 |* Input parameters: *| 04121 |* la_ch opening paren of program string *| 04122 |* *| 04123 |* Output parameters: *| 04124 |* la_ch next character of input source statement *| 04125 |* *| 04126 |* Returns: *| 04127 |* TRUE indicates a program string token was produced. *| 04128 |* FALSE indicates that an error was encountered. *| 04129 |* *| 04130 \******************************************************************************/ 04131 04132 static boolean get_program_str (void) 04133 04134 { 04135 int paren_lvl = 0; 04136 boolean result = TRUE; 04137 04138 04139 TRACE (Func_Entry, "get_program_str", NULL); 04140 04141 # ifdef _DEBUG 04142 if (LA_CH_VALUE != LPAREN) { 04143 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 04144 "get_program_str", "("); 04145 } 04146 # endif 04147 04148 /* Scan thru the program string, checking if the paren groups are matched. */ 04149 /* Do not save anything in the TOKEN. Cray treats this as a comment. */ 04150 04151 do { 04152 if (LA_CH_VALUE == LPAREN) { 04153 paren_lvl++; 04154 } 04155 else if (LA_CH_VALUE == RPAREN) { 04156 paren_lvl--; 04157 } 04158 NEXT_LA_CH; 04159 } 04160 while (paren_lvl > 0 && LA_CH_VALUE != EOS); 04161 04162 if (paren_lvl > 0) { /* Trailing ")" is missing in program string. */ 04163 PRINTMSG (TOKEN_LINE(token), 28, Error, TOKEN_COLUMN(token)); 04164 result = FALSE; 04165 } 04166 04167 TRACE (Func_Exit, "get_program_str", NULL); 04168 04169 return (result); 04170 04171 } /* get_program_str */ 04172 04173 /******************************************************************************\ 04174 |* *| 04175 |* Description: *| 04176 |* Get_punctuator is called by the get_token routine to attempt *| 04177 |* recognition of a punctuator token using the look ahead character and *| 04178 |* following characters of the input source. *| 04179 |* *| 04180 |* EOS is considered a punctuator token. Get_punctuator is responsible *| 04181 |* for skipping redundant EOS punctuators between statements. *| 04182 |* *| 04183 |* Input parameters: *| 04184 |* la_ch first character of punctuator token *| 04185 |* *| 04186 |* Output parameters: *| 04187 |* la_ch next character of input source statement *| 04188 |* token token created by get_punctuator *| 04189 |* *| 04190 |* Returns: *| 04191 |* TRUE indicates a punctuator token was produced. *| 04192 |* FALSE indicates that an error was encountered. *| 04193 |* *| 04194 \******************************************************************************/ 04195 04196 static boolean get_punctuator (void) 04197 04198 { 04199 char punct_ch; 04200 int tok_len = 0; 04201 04202 TRACE (Func_Entry, "get_punctuator", NULL); 04203 04204 punct_ch = LA_CH_VALUE; 04205 TOKEN_STR(token)[0] = punct_ch; 04206 tok_len = 1; 04207 04208 NEXT_LA_CH; /* punct may be multi-character */ 04209 04210 switch (punct_ch) { 04211 case COLON : 04212 if (LA_CH_VALUE == COLON && !sig_blank) { 04213 TOKEN_VALUE(token) = Tok_Punct_Colon_Colon; 04214 TOKEN_STR(token)[1] = COLON; 04215 tok_len = 2; 04216 NEXT_LA_CH; 04217 } 04218 else { 04219 TOKEN_VALUE(token) = Tok_Punct_Colon; 04220 } 04221 break; 04222 04223 case COMMA : 04224 TOKEN_VALUE(token) = Tok_Punct_Comma; 04225 break; 04226 04227 case DASH : 04228 TOKEN_VALUE(token) = Tok_Punct_Dash; 04229 break; 04230 04231 case EOS : 04232 TOKEN_VALUE(token) = Tok_EOS; 04233 break; 04234 04235 case EQUAL : 04236 if (LA_CH_VALUE == GT && !sig_blank) { 04237 TOKEN_VALUE(token) = Tok_Punct_Rename; 04238 TOKEN_STR(token)[1] = GT; 04239 tok_len = 2; 04240 NEXT_LA_CH; 04241 } 04242 else { 04243 TOKEN_VALUE(token) = Tok_Punct_Eq; 04244 } 04245 break; 04246 04247 case LPAREN : 04248 if (LA_CH_VALUE == SLASH && !sig_blank) { 04249 TOKEN_VALUE(token) = Tok_Punct_Lbrkt; 04250 TOKEN_STR(token)[1] = SLASH; 04251 tok_len = 2; 04252 NEXT_LA_CH; 04253 } 04254 else { 04255 TOKEN_VALUE(token) = Tok_Punct_Lparen; 04256 } 04257 break; 04258 04259 case RPAREN : 04260 TOKEN_VALUE(token) = Tok_Punct_Rparen; 04261 break; 04262 04263 case SLASH : 04264 if (LA_CH_VALUE == RPAREN && !sig_blank) { 04265 TOKEN_VALUE(token) = Tok_Punct_Rbrkt; 04266 TOKEN_STR(token)[1] = RPAREN; 04267 tok_len = 2; 04268 NEXT_LA_CH; 04269 } 04270 else { 04271 TOKEN_VALUE(token) = Tok_Punct_Slash; 04272 } 04273 break; 04274 04275 case STAR : 04276 TOKEN_VALUE(token) = Tok_Punct_Star; 04277 break; 04278 04279 default : 04280 TOKEN_VALUE(token) = Tok_Unknown; 04281 break; 04282 } /* switch */ 04283 04284 TOKEN_LEN(token) = tok_len; 04285 04286 TRACE (Func_Exit, "get_punctuator", NULL); 04287 04288 return (TRUE); 04289 04290 } /* get_punctuator */ 04291 04292 04293 /******************************************************************************\ 04294 |* *| 04295 |* Description: *| 04296 |* ch_after_paren_grp *| 04297 |* initial implementation. Does not handle hollerith. *| 04298 |* Needs to be rewritten before it gets to the real world. *| 04299 |* Parse needs to be positioned with LA_CH_VALUE = to LPAREN. *| 04300 |* *| 04301 |* Input parameters: *| 04302 |* NONE *| 04303 |* *| 04304 |* Output parameters: *| 04305 |* NONE *| 04306 |* *| 04307 |* Returns: *| 04308 |* If the lookahead is a left paren, it searches for the character *| 04309 |* following the right paren and returns it. If there is no right paren,*| 04310 |* it returns EOS char. If the lookahead is not a left paren, it returns*| 04311 |* the lookahead. *| 04312 |* *| 04313 \******************************************************************************/ 04314 04315 char ch_after_paren_grp(void) 04316 04317 { 04318 char return_char; 04319 04320 04321 TRACE (Func_Entry, "ch_after_paren_grp", &LA_CH_VALUE); 04322 04323 return_char = scan_thru_close_paren(0,0,1); 04324 04325 TRACE (Func_Exit, "ch_after_paren_grp", &return_char); 04326 04327 return(return_char); 04328 04329 } /* ch_after_paren_grp */ 04330 04331 /******************************************************************************\ 04332 |* *| 04333 |* Description: *| 04334 |* convert numeric constants that possibly have kind parameters. *| 04335 |* *| 04336 |* Input parameters: *| 04337 |* NONE *| 04338 |* *| 04339 |* Output parameters: *| 04340 |* NONE *| 04341 |* *| 04342 |* Returns: *| 04343 |* TRUE if no problems. *| 04344 |* *| 04345 \******************************************************************************/ 04346 04347 static boolean convert_const(void) 04348 04349 { 04350 int attr_idx; 04351 long bytes = 0; 04352 long_type constant[MAX_WORDS_FOR_NUMERIC]; 04353 linear_type_type linear_type; 04354 id_str_type name; 04355 int name_idx; 04356 boolean result_ok = TRUE; 04357 int type_idx; 04358 type_desc_type type_kind = Default_Typed; 04359 04360 04361 TRACE (Func_Entry, "convert_const", NULL); 04362 04363 TOKEN_CONST_TBL_IDX(token) = NULL_IDX; 04364 04365 if (TOKEN_KIND_LEN(token) != 0) { 04366 04367 if (TOKEN_KIND_STR(token)[0] >= '0' && TOKEN_KIND_STR(token)[0] <= '9') { 04368 errno = 0; 04369 bytes = LEX_STRTOL(TOKEN_KIND_STR(token), (char **) NULL, 10); 04370 04371 if (errno != 0) { 04372 result_ok = FALSE; 04373 PRINTMSG(TOKEN_LINE(token), 621, Error, 04374 TOKEN_COLUMN(token), 04375 TOKEN_KIND_STR(token)); 04376 } 04377 else { 04378 type_kind = Kind_Typed; 04379 } 04380 } 04381 else { 04382 CREATE_ID(name, TOKEN_KIND_STR(token), TOKEN_KIND_LEN(token)); 04383 attr_idx = srch_sym_tbl(name.string, 04384 TOKEN_KIND_LEN(token), 04385 &name_idx); 04386 04387 if (attr_idx == NULL_IDX) { 04388 attr_idx = srch_host_sym_tbl(name.string, 04389 TOKEN_KIND_LEN(token), 04390 &name_idx, 04391 TRUE); 04392 } 04393 04394 if (attr_idx == NULL_IDX) { /* error .. no parameter */ 04395 PRINTMSG(TOKEN_LINE(token), 129, Error, TOKEN_COLUMN(token)); 04396 result_ok = FALSE; 04397 } 04398 else { 04399 04400 while (AT_ATTR_LINK(attr_idx) != NULL_IDX) { 04401 attr_idx = AT_ATTR_LINK(attr_idx); 04402 } 04403 04404 if (AT_NOT_VISIBLE(attr_idx)) { 04405 PRINTMSG(TOKEN_LINE(token), 486, Error, 04406 TOKEN_COLUMN(token), 04407 AT_OBJ_NAME_PTR(attr_idx), 04408 AT_OBJ_NAME_PTR(AT_MODULE_IDX((attr_idx)))); 04409 result_ok = FALSE; 04410 } 04411 else if (AT_OBJ_CLASS(attr_idx) == Data_Obj && 04412 ATD_CLASS(attr_idx) == Constant && 04413 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Integer && 04414 ATD_ARRAY_IDX(attr_idx) == NULL_IDX) { 04415 bytes = (long)CN_INT_TO_C(ATD_CONST_IDX(attr_idx)); 04416 type_kind = Kind_Typed; 04417 } 04418 else { /* error .. kind must be integer or integer parameter */ 04419 PRINTMSG(TOKEN_LINE(token), 129, Error, TOKEN_COLUMN(token)); 04420 result_ok = FALSE; 04421 } 04422 } 04423 } 04424 } 04425 04426 switch (TOKEN_VALUE(token)) { 04427 case Tok_Const_Int : 04428 04429 if (type_kind == Default_Typed) { 04430 type_idx = INTEGER_DEFAULT_TYPE; 04431 } 04432 else if (!validate_kind(Integer, 04433 TOKEN_LINE(token), 04434 TOKEN_COLUMN(token), 04435 &bytes, 04436 &linear_type)) { 04437 04438 type_idx = INTEGER_DEFAULT_TYPE; 04439 result_ok = FALSE; 04440 } 04441 else { 04442 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 04443 TYP_TYPE(TYP_WORK_IDX) = Integer; 04444 TYP_LINEAR(TYP_WORK_IDX) = linear_type; 04445 TYP_DCL_VALUE(TYP_WORK_IDX) = bytes; 04446 TYP_DESC(TYP_WORK_IDX) = Kind_Typed; 04447 type_idx = ntr_type_tbl(); 04448 } 04449 04450 CONVERT_INT_CONST(type_idx, TOKEN_LEN(token), result_ok); 04451 break; 04452 04453 case Tok_Const_Real : 04454 04455 if (type_kind == Default_Typed) { 04456 type_idx = REAL_DEFAULT_TYPE; 04457 CONVERT_REAL_CONST(type_idx, TOKEN_LEN(token), result_ok); 04458 } 04459 else if (!validate_kind(Real, 04460 TOKEN_LINE(token), 04461 TOKEN_COLUMN(token), 04462 &bytes, 04463 &linear_type)) { 04464 type_idx = REAL_DEFAULT_TYPE; 04465 result_ok = FALSE; 04466 CONVERT_REAL_CONST(type_idx, TOKEN_LEN(token), result_ok); 04467 } 04468 else { 04469 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 04470 TYP_TYPE(TYP_WORK_IDX) = Real; 04471 TYP_LINEAR(TYP_WORK_IDX) = linear_type; 04472 TYP_DCL_VALUE(TYP_WORK_IDX) = bytes; 04473 TYP_DESC(TYP_WORK_IDX) = Kind_Typed; 04474 type_idx = ntr_type_tbl(); 04475 04476 # ifdef _TARGET64 04477 if (linear_type > Real_8) 04478 # else 04479 if (linear_type > Real_4) 04480 # endif 04481 { 04482 CONVERT_DBL_CONST(type_idx, TOKEN_LEN(token), result_ok); 04483 } 04484 else { 04485 CONVERT_REAL_CONST(type_idx, TOKEN_LEN(token), result_ok); 04486 } 04487 } 04488 break; 04489 04490 case Tok_Const_True : 04491 case Tok_Const_False : 04492 04493 if (type_kind == Default_Typed) { 04494 type_idx = LOGICAL_DEFAULT_TYPE; 04495 } 04496 else if (!validate_kind(Logical, 04497 TOKEN_LINE(token), 04498 TOKEN_COLUMN(token), 04499 &bytes, 04500 &linear_type)) { 04501 type_idx = LOGICAL_DEFAULT_TYPE; 04502 result_ok = FALSE; 04503 } 04504 else { 04505 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 04506 TYP_TYPE(TYP_WORK_IDX) = Logical; 04507 TYP_LINEAR(TYP_WORK_IDX) = linear_type; 04508 TYP_DCL_VALUE(TYP_WORK_IDX) = bytes; 04509 TYP_DESC(TYP_WORK_IDX) = Kind_Typed; 04510 type_idx = ntr_type_tbl(); 04511 } 04512 04513 TOKEN_CONST_TBL_IDX(token) = set_up_logical_constant(constant, 04514 type_idx, 04515 (TOKEN_VALUE(token) == Tok_Const_True ? TRUE_VALUE : 04516 FALSE_VALUE), 04517 TRUE); 04518 break; 04519 04520 case Tok_Const_Char : 04521 04522 if (type_kind != Default_Typed && !validate_kind(Character, 04523 TOKEN_LINE(token), 04524 TOKEN_COLUMN(token), 04525 &bytes, 04526 &linear_type)) { 04527 result_ok = FALSE; 04528 } 04529 break; 04530 } 04531 04532 TRACE (Func_Exit, "convert_const", NULL); 04533 04534 return(result_ok); 04535 04536 } /* convert_const */ 04537 04538 /******************************************************************************\ 04539 |* *| 04540 |* Description: *| 04541 |* <description> *| 04542 |* *| 04543 |* Input parameters: *| 04544 |* NONE *| 04545 |* *| 04546 |* Output parameters: *| 04547 |* NONE *| 04548 |* *| 04549 |* Returns: *| 04550 |* NOTHING *| 04551 |* *| 04552 \******************************************************************************/ 04553 04554 token_values_type get_dir_token_from_str(char *str) 04555 04556 { 04557 int beg_idx; 04558 int i; 04559 int letter_idx; 04560 int lim_idx; 04561 char upper_str[MAX_KWD_LEN + 1]; 04562 int str_len = 0; 04563 token_values_type value = Tok_Unknown; 04564 04565 04566 TRACE (Func_Entry, "get_dir_token_from_str", NULL); 04567 04568 str_len = 0; 04569 i = 0; 04570 04571 while (str[i] != '\0') { 04572 if (str[i] == ' ' || str[i] == '\t') { 04573 i++; 04574 } 04575 else { 04576 if (ch_class[str[i]] != Ch_Class_Letter && 04577 str[i] != USCORE) { 04578 goto EXIT; 04579 } 04580 else if (islower(str[i])) { 04581 upper_str[str_len] = TOUPPER(str[i]); 04582 } 04583 else { 04584 upper_str[str_len] = str[i]; 04585 } 04586 str_len++; 04587 i++; 04588 } 04589 } 04590 04591 if (ch_class[upper_str[0]] != Ch_Class_Letter) { 04592 goto EXIT; 04593 } 04594 04595 letter_idx = upper_str[0] - 'A'; 04596 beg_idx = kwd_dir_idx[letter_idx]; 04597 lim_idx = kwd_dir_idx[letter_idx+1]; 04598 04599 if (beg_idx != lim_idx) { 04600 04601 if (str_len >= kwd_dir_len[lim_idx-1]) { 04602 04603 while (beg_idx < lim_idx) { 04604 04605 if (kwd_dir_len[beg_idx] == str_len && 04606 strncmp(upper_str, 04607 kwd_dir[beg_idx].name, 04608 kwd_dir_len[beg_idx]) == IDENTICAL) { 04609 04610 value = kwd_dir[beg_idx].value; 04611 04612 break; 04613 } 04614 04615 beg_idx++; 04616 04617 } /* while */ 04618 } /* if */ 04619 } /* if */ 04620 04621 if (value == Tok_Unknown && 04622 ((strncmp("ALL", upper_str, 3) == IDENTICAL) || 04623 (strncmp("DIR", upper_str, 3) == IDENTICAL) || 04624 (strncmp("MIC", upper_str, 3) == IDENTICAL) || 04625 (strncmp("MIPSPRO", upper_str, 7) == IDENTICAL) || 04626 (strncmp("OMP", upper_str, 3) == IDENTICAL) || 04627 (strncmp("CONDITIONAL_OMP", upper_str, 15) == IDENTICAL) || 04628 (strncmp("OPENAD", upper_str, 6) == IDENTICAL) || /* eraxxon: OpenAD */ 04629 (strncmp("MPP", upper_str, 3) == IDENTICAL))) { 04630 04631 /* Tok_Id is a signal to cmd_line that "all" or "mpp" was specified */ 04632 04633 value = Tok_Id; 04634 } 04635 else if (value == Tok_Unknown) { /* See if it is a MIC keyword */ 04636 letter_idx = upper_str[0] - 'A'; 04637 beg_idx = kwd_mic_idx[letter_idx]; 04638 lim_idx = kwd_mic_idx[letter_idx+1]; 04639 04640 if (beg_idx != lim_idx) { 04641 04642 if (str_len >= kwd_mic_len[lim_idx-1]) { 04643 04644 while (beg_idx < lim_idx) { 04645 04646 if (kwd_mic_len[beg_idx] == str_len && 04647 strncmp(upper_str, 04648 kwd_mic[beg_idx].name, 04649 kwd_mic_len[beg_idx]) == IDENTICAL) { 04650 04651 value = kwd_mic[beg_idx].value; 04652 04653 break; 04654 } 04655 04656 beg_idx++; 04657 04658 } /* while */ 04659 } 04660 } 04661 } 04662 04663 if (value == Tok_Unknown) { /* See if it is an OpenMp keyword */ 04664 letter_idx = upper_str[0] - 'A'; 04665 beg_idx = kwd_open_mp_dir_idx[letter_idx]; 04666 lim_idx = kwd_open_mp_dir_idx[letter_idx+1]; 04667 04668 if (beg_idx != lim_idx) { 04669 04670 if (str_len >= kwd_open_mp_dir_len[lim_idx-1]) { 04671 04672 while (beg_idx < lim_idx) { 04673 04674 if (kwd_open_mp_dir_len[beg_idx] == str_len && 04675 strncmp(upper_str, 04676 kwd_open_mp_dir[beg_idx].name, 04677 kwd_open_mp_dir_len[beg_idx]) == IDENTICAL) { 04678 04679 value = kwd_open_mp_dir[beg_idx].value; 04680 04681 break; 04682 } 04683 04684 beg_idx++; 04685 04686 } /* while */ 04687 } 04688 } 04689 } 04690 04691 if (value == Tok_Unknown) { /* See if it is an Mips keyword */ 04692 letter_idx = upper_str[0] - 'A'; 04693 beg_idx = kwd_sgi_dir_idx[letter_idx]; 04694 lim_idx = kwd_sgi_dir_idx[letter_idx+1]; 04695 04696 if (beg_idx != lim_idx) { 04697 04698 if (str_len >= kwd_sgi_dir_len[lim_idx-1]) { 04699 04700 while (beg_idx < lim_idx) { 04701 04702 if (kwd_sgi_dir_len[beg_idx] == str_len && 04703 strncmp(upper_str, 04704 kwd_sgi_dir[beg_idx].name, 04705 kwd_sgi_dir_len[beg_idx]) == IDENTICAL) { 04706 04707 value = kwd_sgi_dir[beg_idx].value; 04708 04709 break; 04710 } 04711 04712 beg_idx++; 04713 04714 } /* while */ 04715 } 04716 } 04717 } 04718 04719 /* eraxxon: OpenAD directive: do not support selective disabling */ 04720 04721 EXIT: 04722 04723 TRACE (Func_Exit, "get_dir_token_from_str", NULL); 04724 04725 return(value); 04726 04727 } /* get_dir_token_from_str */ 04728 04729 # ifdef _DEBUG 04730 /******************************************************************************\ 04731 |* *| 04732 |* Description: *| 04733 |* Get_debug_directive is called by the get_token routine to attempt *| 04734 |* recognition of a debug keyword by matching the look ahead char *| 04735 |* and following characters of class Ch_Class_Letter with entries in the *| 04736 |* kwd_dbg table. If a keyword is not found, an id token is created. *| 04737 |* *| 04738 |* Input parameters: *| 04739 |* la_ch first character of debug kwd token *| 04740 |* *| 04741 |* Output parameters: *| 04742 |* la_ch next character of input source statement *| 04743 |* token token created by get_debug_directive *| 04744 |* *| 04745 |* Returns: *| 04746 |* TRUE indicates a keyword or id token was produced. *| 04747 |* FALSE indicates that an error was encountered. *| 04748 |* *| 04749 \******************************************************************************/ 04750 04751 static boolean get_debug_directive (void) 04752 04753 { 04754 int beg_idx; 04755 la_type la_queue[MAX_KWD_LEN + 1]; 04756 int letter_idx; 04757 int lim_idx; 04758 int tok_len = 0; 04759 04760 04761 TRACE (Func_Entry, "get_debug_directive", NULL); 04762 04763 # ifdef _DEBUG 04764 if (LA_CH_CLASS != Ch_Class_Letter) { 04765 PRINTMSG(TOKEN_LINE(token), 295, Internal, TOKEN_COLUMN(token), 04766 "get_debug_directive", "letter"); 04767 } 04768 # endif 04769 04770 TOKEN_VALUE(token) = Tok_Id; 04771 04772 /* check for any microtasking keywords starting with look ahead char */ 04773 letter_idx = LA_CH_VALUE - 'A'; 04774 04775 beg_idx = kwd_dbg_idx[letter_idx]; 04776 lim_idx = kwd_dbg_idx[letter_idx+1]; 04777 04778 if (beg_idx != lim_idx) { 04779 04780 #ifdef _DEBUG 04781 if (kwd_dbg_len[beg_idx] > MAX_ID_LEN) { 04782 PRINTMSG(TOKEN_LINE(token), 384, Internal, TOKEN_COLUMN(token), 04783 beg_idx, kwd_dbg_len[beg_idx]); 04784 } 04785 # endif 04786 04787 while (LA_CH_CLASS == Ch_Class_Letter && tok_len < kwd_dbg_len[beg_idx]) { 04788 la_queue[tok_len] = la_ch; 04789 TOKEN_STR(token)[tok_len] = LA_CH_VALUE; 04790 tok_len++; 04791 NEXT_LA_CH; 04792 } 04793 04794 TOKEN_LEN(token) = tok_len; 04795 04796 if (tok_len >= kwd_dbg_len[lim_idx-1]) { 04797 04798 /* compare token string to debug keyword entries */ 04799 04800 while (beg_idx < lim_idx) { 04801 04802 if (kwd_dbg_len[beg_idx] <= tok_len) { 04803 04804 if (strncmp(TOKEN_STR(token), 04805 kwd_dbg[beg_idx].name, 04806 kwd_dbg_len[beg_idx]) == IDENTICAL) { 04807 04808 /* the following chars and preceding letter can't be */ 04809 /* part of a keyword on full length match of string. */ 04810 04811 if (tok_len == kwd_dbg_len[beg_idx] && 04812 (LA_CH_VALUE == USCORE || 04813 LA_CH_VALUE == DOLLAR || 04814 LA_CH_VALUE == AT_SIGN)) { 04815 } 04816 else { 04817 TOKEN_VALUE(token) = kwd_dbg[beg_idx].value; 04818 04819 /* adjust la_ch to be char following keyword */ 04820 04821 if (tok_len > kwd_dbg_len[beg_idx]) { 04822 tok_len = kwd_dbg_len[beg_idx]; 04823 la_ch = la_queue[tok_len]; 04824 TOKEN_LEN(token) = tok_len; 04825 04826 /* reset src input buffer and col index to la_ch pos */ 04827 reset_src_input (LA_CH_BUF_IDX, LA_CH_STMT_NUM); 04828 } 04829 break; 04830 } 04831 } 04832 } /* if */ 04833 04834 beg_idx++; 04835 04836 } /* while */ 04837 } /* if */ 04838 } /* if */ 04839 04840 if (TOKEN_VALUE(token) == Tok_Id) { /* keyword not found */ 04841 04842 while (VALID_LA_CH) { 04843 ADD_TO_TOKEN_STR (LA_CH_VALUE, tok_len); 04844 NEXT_LA_CH; 04845 } 04846 04847 if (tok_len > MAX_ID_LEN) { /* Id len exceeds maximum of 31 characters. */ 04848 PRINTMSG (TOKEN_LINE(token), 67, Error, TOKEN_COLUMN(token)); 04849 tok_len = MAX_ID_LEN; 04850 } 04851 TOKEN_LEN(token) = tok_len; 04852 } 04853 04854 TRACE (Func_Exit, "get_debug_directive", NULL); 04855 04856 return (TRUE); 04857 04858 } /* get_debug_directive */ 04859 # endif 04860 04861 /******************************************************************************\ 04862 |* *| 04863 |* Description: *| 04864 |* <description> *| 04865 |* *| 04866 |* Input parameters: *| 04867 |* NONE *| 04868 |* *| 04869 |* Output parameters: *| 04870 |* NONE *| 04871 |* *| 04872 |* Returns: *| 04873 |* NOTHING *| 04874 |* *| 04875 \******************************************************************************/ 04876 04877 static void convert_octal_literal(boolean is_boz) 04878 04879 { 04880 int i; 04881 int idx; 04882 int num_bits; 04883 int num_words; 04884 long_type result[MAX_WORDS_FOR_NUMERIC]; 04885 int shift; 04886 int temp; 04887 int type_idx; 04888 int word; 04889 04890 TRACE (Func_Entry, "convert_octal_literal", NULL); 04891 04892 04893 num_bits = ((TOKEN_LEN(token) - 1) * 3); 04894 temp = const_buf[0] - '0'; 04895 04896 num_bits += 04897 ((temp & 4) != 0 ? 3 : ((temp & 2) != 0 ? 2 : ((temp & 1) != 0 ? 1 : 0))); 04898 04899 num_words = (num_bits + TARGET_BITS_PER_WORD - 1) / TARGET_BITS_PER_WORD; 04900 04901 if (num_words == 0) { 04902 num_words = 1; 04903 } 04904 04905 /* clear result array */ 04906 for (i = 0; i < MAX_WORDS_FOR_NUMERIC; i++) { 04907 result[i] = 0; 04908 } 04909 04910 word = num_words - 1; 04911 04912 idx = TOKEN_LEN(token) - 1; 04913 shift = 0; 04914 04915 while (idx >= 0) { 04916 04917 if (shift > (TARGET_BITS_PER_WORD - 1)) { 04918 shift = 0; 04919 word--; 04920 } 04921 04922 temp = const_buf[idx] - '0'; 04923 idx--; 04924 04925 result[word] |= ((temp & 1) << shift); 04926 shift++; 04927 04928 if (shift > (TARGET_BITS_PER_WORD - 1)) { 04929 shift = 0; 04930 word--; 04931 } 04932 04933 result[word] |= (((temp >> 1) & 1) << shift); 04934 shift++; 04935 04936 if (shift > (TARGET_BITS_PER_WORD - 1)) { 04937 shift = 0; 04938 word--; 04939 } 04940 04941 result[word] |= (((temp >> 2) & 1) << shift); /* BRIANJ */ 04942 shift++; 04943 } 04944 04945 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 04946 TYP_TYPE(TYP_WORK_IDX) = Typeless; 04947 TYP_LINEAR(TYP_WORK_IDX) = Short_Typeless_Const; 04948 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words * TARGET_BITS_PER_WORD); 04949 type_idx = ntr_type_tbl(); 04950 04951 if (is_boz) { 04952 TOKEN_CONST_TBL_IDX(token) = ntr_boz_const_tbl(type_idx, 04953 result); 04954 } 04955 else { 04956 TOKEN_CONST_TBL_IDX(token) = ntr_boolean_const_tbl(type_idx, 04957 result); 04958 } 04959 04960 04961 TRACE (Func_Exit, "convert_octal_literal", NULL); 04962 04963 return; 04964 04965 } /* convert_octal_literal */ 04966 04967 /******************************************************************************\ 04968 |* *| 04969 |* Description: *| 04970 |* <description> *| 04971 |* *| 04972 |* Input parameters: *| 04973 |* NONE *| 04974 |* *| 04975 |* Output parameters: *| 04976 |* NONE *| 04977 |* *| 04978 |* Returns: *| 04979 |* NOTHING *| 04980 |* *| 04981 \******************************************************************************/ 04982 04983 static void convert_hex_literal(boolean is_boz) 04984 04985 { 04986 int i; 04987 int idx; 04988 int base; 04989 int bits; 04990 char *char_ptr; 04991 long_type constant[MAX_WORDS_FOR_NUMERIC]; 04992 int const_idx; 04993 int count; 04994 int digits_per_word; 04995 int num_digits; 04996 int num_words; 04997 boolean negate = FALSE; 04998 long_type result[MAX_WORDS_FOR_NUMERIC]; 04999 char tmpstr[80]; 05000 int type_idx; 05001 int word; 05002 05003 05004 TRACE (Func_Entry, "convert_hex_literal", NULL); 05005 05006 if (const_buf[0] == PLUS) { 05007 num_digits = TOKEN_LEN(token) - 1; 05008 char_ptr = &(const_buf[1]); 05009 } 05010 else if (const_buf[0] == MINUS) { 05011 num_digits = TOKEN_LEN(token) - 1; 05012 char_ptr = &(const_buf[1]); 05013 negate = TRUE; 05014 } 05015 else { 05016 num_digits = TOKEN_LEN(token); 05017 char_ptr = const_buf; 05018 } 05019 05020 digits_per_word = TARGET_BITS_PER_WORD / 4; 05021 05022 num_words = (num_digits + digits_per_word - 1) / digits_per_word; 05023 05024 /* clear result array */ 05025 for (i = 0; i < MAX_WORDS_FOR_NUMERIC; i++) { 05026 result[i] = 0; /* BRIANJ - SHould we set this to target value? */ 05027 } 05028 05029 word = num_words - 1; 05030 idx = num_digits - digits_per_word; 05031 05032 while (word >= 0) { 05033 05034 if (idx < 0) { 05035 count = digits_per_word + idx; 05036 idx = 0; 05037 } 05038 else { 05039 count = digits_per_word; 05040 } 05041 05042 strncpy(tmpstr, &(char_ptr[idx]), count); 05043 tmpstr[count] = '\0'; 05044 05045 # ifdef _ARITH_INPUT_CONV 05046 base = 16; 05047 05048 i = AR_convert_str_to_int((AR_DATA *)constant, 05049 (const AR_TYPE *)&input_arith_type[CG_INTEGER_DEFAULT_TYPE], 05050 &bits, 05051 (const char *)tmpstr, 05052 (const int *)&base); 05053 SHIFT_ARITH_RESULT(constant, CG_INTEGER_DEFAULT_TYPE); 05054 result[word] = constant[0]; 05055 05056 # else 05057 # if defined(_HOST32) && defined(_TARGET64) 05058 05059 result[word] = (long_type) strtoull(tmpstr, (char **) NULL, 16); 05060 05061 # else 05062 05063 result[word] = strtoul(tmpstr, (char **) NULL, 16); 05064 05065 # endif 05066 # endif 05067 05068 idx -= digits_per_word; 05069 word--; 05070 } 05071 05072 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05073 TYP_TYPE(TYP_WORK_IDX) = Typeless; 05074 TYP_LINEAR(TYP_WORK_IDX) = Short_Typeless_Const; 05075 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words * TARGET_BITS_PER_WORD); 05076 type_idx = ntr_type_tbl(); 05077 05078 if (is_boz) { 05079 const_idx = ntr_boz_const_tbl(type_idx, result); 05080 } 05081 else { 05082 const_idx = ntr_boolean_const_tbl(type_idx, result); 05083 } 05084 05085 05086 /* BHJ - need to check for '-' and do the fold. The constant is */ 05087 /* truncated to default integer size. */ 05088 05089 if (negate) { 05090 const_idx = cast_typeless_constant(const_idx, 05091 TYPELESS_DEFAULT_TYPE, 05092 TOKEN_LINE(token), 05093 TOKEN_COLUMN(token)); 05094 05095 type_idx = INTEGER_DEFAULT_TYPE; 05096 if (folder_driver((char *)&CN_CONST(const_idx), 05097 INTEGER_DEFAULT_TYPE, 05098 NULL, 05099 NULL_IDX, 05100 constant, 05101 &type_idx, 05102 TOKEN_LINE(token), 05103 TOKEN_COLUMN(token), 05104 1, 05105 Uminus_Opr)) { 05106 05107 if (is_boz) { 05108 const_idx = ntr_boz_const_tbl(TYPELESS_DEFAULT_TYPE, constant); 05109 } 05110 else { 05111 const_idx = ntr_boolean_const_tbl(TYPELESS_DEFAULT_TYPE, constant); 05112 } 05113 } 05114 } 05115 05116 TOKEN_CONST_TBL_IDX(token) = const_idx; 05117 05118 TRACE (Func_Exit, "convert_hex_literal", NULL); 05119 05120 return; 05121 05122 } /* convert_hex_literal */ 05123 05124 /******************************************************************************\ 05125 |* *| 05126 |* Description: *| 05127 |* <description> *| 05128 |* *| 05129 |* Input parameters: *| 05130 |* NONE *| 05131 |* *| 05132 |* Output parameters: *| 05133 |* NONE *| 05134 |* *| 05135 |* Returns: *| 05136 |* NOTHING *| 05137 |* *| 05138 \******************************************************************************/ 05139 05140 static void convert_binary_literal(boolean is_boz) 05141 05142 { 05143 int i; 05144 int idx; 05145 int base; 05146 int bits; 05147 long_type constant[MAX_WORDS_FOR_NUMERIC]; 05148 int count; 05149 int digits_per_word; 05150 int num_digits; 05151 int num_words; 05152 long_type result[MAX_WORDS_FOR_NUMERIC]; 05153 char tmpstr[80]; 05154 int type_idx; 05155 int word; 05156 05157 05158 TRACE (Func_Entry, "convert_binary_literal", NULL); 05159 05160 num_digits = TOKEN_LEN(token); 05161 05162 digits_per_word = TARGET_BITS_PER_WORD; 05163 05164 num_words = (num_digits + digits_per_word - 1) / digits_per_word; 05165 05166 /* clear result array */ 05167 for (i = 0; i < MAX_WORDS_FOR_NUMERIC; i++) { 05168 result[i] = 0; /* BRIANJ - Do we need a target value */ 05169 } 05170 05171 word = num_words - 1; 05172 idx = num_digits - digits_per_word; 05173 05174 while (word >= 0) { 05175 05176 if (idx < 0) { 05177 count = digits_per_word + idx; 05178 idx = 0; 05179 } 05180 else { 05181 count = digits_per_word; 05182 } 05183 05184 strncpy(tmpstr, &(const_buf[idx]), count); 05185 tmpstr[count] = '\0'; 05186 05187 # ifdef _ARITH_INPUT_CONV 05188 base = 2; 05189 05190 i = AR_convert_str_to_int((AR_DATA *)constant, 05191 (const AR_TYPE *)&input_arith_type[CG_INTEGER_DEFAULT_TYPE], 05192 &bits, 05193 (const char *)tmpstr, 05194 (const int *)&base); 05195 SHIFT_ARITH_RESULT(constant, CG_INTEGER_DEFAULT_TYPE); 05196 result[word] = constant[0]; 05197 05198 # else 05199 # if defined(_HOST32) && defined(_TARGET64) 05200 05201 result[word] = (long_type) strtoull(tmpstr, (char **) NULL, 2); 05202 05203 # else 05204 05205 result[word] = strtoul(tmpstr, (char **) NULL, 2); 05206 05207 # endif 05208 # endif 05209 05210 idx -= digits_per_word; 05211 word--; 05212 } 05213 05214 CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX); 05215 TYP_TYPE(TYP_WORK_IDX) = Typeless; 05216 TYP_LINEAR(TYP_WORK_IDX) = Short_Typeless_Const; 05217 TYP_BIT_LEN(TYP_WORK_IDX) = (num_words * TARGET_BITS_PER_WORD); 05218 type_idx = ntr_type_tbl(); 05219 05220 if (is_boz) { 05221 TOKEN_CONST_TBL_IDX(token) = ntr_boz_const_tbl(type_idx, 05222 result); 05223 } 05224 else { 05225 TOKEN_CONST_TBL_IDX(token) = ntr_boolean_const_tbl(type_idx, 05226 result); 05227 } 05228 05229 05230 TRACE (Func_Exit, "convert_binary_literal", NULL); 05231 05232 return; 05233 05234 } /* convert_binary_literal */ 05235 05236 /******************************************************************************\ 05237 |* *| 05238 |* Description: *| 05239 |* This routine takes a character string as input and, using the proper *| 05240 |* input conversion routines, creates a fortran constant (a CN_Tbl_Idx) *| 05241 |* It exists so that the frontend can create constants for values such *| 05242 |* as HUGE without worrying about cross compile problems. The strings *| 05243 |* must be proper 'c' numbers (like "1.7976931348623158e+308") and must *| 05244 |* valid for the machine being targeted. Otherwise, an internal compiler *| 05245 |* error will be issued. At this time, ONLY INTEGER and REAL types are *| 05246 |* supported. *| 05247 |* *| 05248 |* Input parameters: *| 05249 |* NONE *| 05250 |* *| 05251 |* Output parameters: *| 05252 |* NONE *| 05253 |* *| 05254 |* Returns: *| 05255 |* NOTHING *| 05256 |* *| 05257 \******************************************************************************/ 05258 05259 int cvrt_str_to_cn(char *str, 05260 int type_idx) 05261 05262 { 05263 int cn_idx; 05264 int len; 05265 boolean ok = TRUE; 05266 token_type save_token; 05267 05268 TRACE (Func_Entry, "cvrt_str_to_cn", NULL); 05269 05270 save_token = token; 05271 05272 strcpy(const_buf, str); 05273 len = strlen(str); 05274 05275 switch (TYP_LINEAR(type_idx)) { 05276 case Integer_1 : 05277 case Integer_2 : 05278 case Integer_4 : 05279 case Integer_8 : 05280 CONVERT_INT_CONST(type_idx, len, ok); 05281 break; 05282 05283 case Real_4 : 05284 CONVERT_REAL_CONST(type_idx, len, ok); 05285 break; 05286 05287 case Real_8 : 05288 # ifdef _TARGET64 05289 CONVERT_REAL_CONST(type_idx, len, ok); 05290 # else 05291 CONVERT_DBL_CONST(type_idx, len, ok); 05292 # endif 05293 break; 05294 05295 case Real_16 : 05296 CONVERT_DBL_CONST(type_idx, len, ok); 05297 break; 05298 05299 default : 05300 PRINTMSG(stmt_start_line, 1190, Internal, 0); 05301 break; 05302 } 05303 05304 if (! ok) { 05305 PRINTMSG(stmt_start_line, 1190, Internal, 0); 05306 } 05307 05308 cn_idx = TOKEN_CONST_TBL_IDX(token); 05309 05310 token = save_token; 05311 05312 TRACE (Func_Exit, "cvrt_str_to_cn", NULL); 05313 05314 return(cn_idx); 05315 05316 } /* cvrt_str_to_cn */ 05317 05318 /******************************************************************************\ 05319 |* *| 05320 |* Description: *| 05321 |* <description> *| 05322 |* *| 05323 |* Input parameters: *| 05324 |* NONE *| 05325 |* *| 05326 |* Output parameters: *| 05327 |* NONE *| 05328 |* *| 05329 |* Returns: *| 05330 |* NOTHING *| 05331 |* *| 05332 \******************************************************************************/ 05333 05334 void set_up_token_tables(void) 05335 05336 { 05337 int i; 05338 int len; 05339 05340 TRACE (Func_Entry, "set_up_token_tables", NULL); 05341 05342 /****************\ 05343 |* dot_op table *| 05344 \****************/ 05345 05346 len = 0; 05347 05348 while (dot_op[len].value != Tok_LAST) { 05349 len++; 05350 } 05351 05352 len++; 05353 05354 dot_op_len = malloc(sizeof(int) * len); 05355 05356 for (i = 0; i < len; i++) { 05357 dot_op_len[i] = strlen(dot_op[i].name); 05358 } 05359 05360 set_up_letter_idx_table(dot_op_idx, dot_op, len); 05361 05362 /*************\ 05363 |* kwd table *| 05364 \*************/ 05365 05366 len = 0; 05367 05368 while (kwd[len].value != Tok_LAST) { 05369 len++; 05370 } 05371 05372 len++; 05373 05374 kwd_len = malloc(sizeof(int) * len); 05375 05376 for (i = 0; i < len; i++) { 05377 kwd_len[i] = strlen(kwd[i].name); 05378 } 05379 05380 set_up_letter_idx_table(kwd_idx, kwd, len); 05381 05382 /* we do not do the alt_kwd here */ 05383 05384 /*****************\ 05385 |* kwd_dir table *| 05386 \*****************/ 05387 05388 len = 0; 05389 05390 while (kwd_dir[len].value != Tok_LAST) { 05391 len++; 05392 } 05393 05394 len++; 05395 05396 kwd_dir_len = malloc(sizeof(int) * len); 05397 05398 for (i = 0; i < len; i++) { 05399 kwd_dir_len[i] = strlen(kwd_dir[i].name); 05400 } 05401 05402 set_up_letter_idx_table(kwd_dir_idx, kwd_dir, len); 05403 05404 /*****************\ 05405 |* kwd_mic table *| 05406 \*****************/ 05407 05408 len = 0; 05409 05410 while (kwd_mic[len].value != Tok_LAST) { 05411 len++; 05412 } 05413 05414 len++; 05415 05416 kwd_mic_len = malloc(sizeof(int) * len); 05417 05418 for (i = 0; i < len; i++) { 05419 kwd_mic_len[i] = strlen(kwd_mic[i].name); 05420 } 05421 05422 set_up_letter_idx_table(kwd_mic_idx, kwd_mic, len); 05423 05424 /*********************\ 05425 |* kwd_sgi_dir table *| 05426 \*********************/ 05427 05428 len = 0; 05429 05430 while (kwd_sgi_dir[len].value != Tok_LAST) { 05431 len++; 05432 } 05433 05434 len++; 05435 05436 kwd_sgi_dir_len = malloc(sizeof(int) * len); 05437 05438 for (i = 0; i < len; i++) { 05439 kwd_sgi_dir_len[i] = strlen(kwd_sgi_dir[i].name); 05440 } 05441 05442 set_up_letter_idx_table(kwd_sgi_dir_idx, kwd_sgi_dir, len); 05443 05444 /*************************\ 05445 |* kwd_open_mp_dir table *| 05446 \*************************/ 05447 05448 len = 0; 05449 05450 while (kwd_open_mp_dir[len].value != Tok_LAST) { 05451 len++; 05452 } 05453 05454 len++; 05455 05456 kwd_open_mp_dir_len = malloc(sizeof(int) * len); 05457 05458 for (i = 0; i < len; i++) { 05459 kwd_open_mp_dir_len[i] = strlen(kwd_open_mp_dir[i].name); 05460 } 05461 05462 set_up_letter_idx_table(kwd_open_mp_dir_idx, kwd_open_mp_dir, len); 05463 05464 /*************************\ 05465 |* kwd_openad_dir table *| 05466 \*************************/ 05467 /* eraxxon: OpenAD directive */ 05468 05469 len = 0; 05470 05471 while (kwd_openad_dir[len].value != Tok_LAST) { 05472 len++; 05473 } 05474 05475 len++; 05476 05477 kwd_openad_dir_len = malloc(sizeof(int) * len); 05478 05479 for (i = 0; i < len; i++) { 05480 kwd_openad_dir_len[i] = strlen(kwd_openad_dir[i].name); 05481 } 05482 05483 set_up_letter_idx_table(kwd_openad_dir_idx, kwd_openad_dir, len); 05484 05485 # ifdef _DEBUG 05486 /*****************\ 05487 |* kwd_dbg table *| 05488 \*****************/ 05489 05490 len = 0; 05491 05492 while (kwd_dbg[len].value != Tok_LAST) { 05493 len++; 05494 } 05495 05496 len++; 05497 05498 kwd_dbg_len = malloc(sizeof(int) * len); 05499 05500 for (i = 0; i < len; i++) { 05501 kwd_dbg_len[i] = strlen(kwd_dbg[i].name); 05502 } 05503 05504 set_up_letter_idx_table(kwd_dbg_idx, kwd_dbg, len); 05505 05506 05507 # endif 05508 05509 TRACE (Func_Exit, "set_up_token_tables", NULL); 05510 05511 return; 05512 05513 } /* set_up_token_tables */ 05514 05515 /******************************************************************************\ 05516 |* *| 05517 |* Description: *| 05518 |* <description> *| 05519 |* *| 05520 |* Input parameters: *| 05521 |* NONE *| 05522 |* *| 05523 |* Output parameters: *| 05524 |* NONE *| 05525 |* *| 05526 |* Returns: *| 05527 |* NOTHING *| 05528 |* *| 05529 \******************************************************************************/ 05530 05531 static void set_up_letter_idx_table(int *idx_tbl, 05532 kwd_type *kwd_tbl, 05533 int len) 05534 05535 { 05536 05537 int i; 05538 int idx; 05539 int k; 05540 05541 TRACE (Func_Entry, "set_up_letter_idx_table", NULL); 05542 05543 for (i = 0; i < 27; i++) { 05544 idx_tbl[i] = len - 1; 05545 } 05546 05547 idx = -1; 05548 for (i = 0; i < len; i++) { 05549 if (kwd_tbl[i].name[0] - 'A' != idx) { 05550 for (k = idx+1; k <= kwd_tbl[i].name[0] - 'A'; k++) { 05551 idx_tbl[k] = i; 05552 } 05553 idx = kwd_tbl[i].name[0] - 'A'; 05554 } 05555 } 05556 05557 # if 0 05558 printf("\t\t\t\t%3d,%4d,%4d,%4d,%4d,%4d,%4d, /* A-G */\n", 05559 idx_tbl[0],idx_tbl[1],idx_tbl[2],idx_tbl[3], 05560 idx_tbl[4],idx_tbl[5],idx_tbl[6]); 05561 printf("\t\t\t\t%3d,%4d,%4d,%4d,%4d,%4d,%4d, /* H-N */\n", 05562 idx_tbl[7],idx_tbl[8],idx_tbl[9],idx_tbl[10], 05563 idx_tbl[11],idx_tbl[12],idx_tbl[13]); 05564 printf("\t\t\t\t%3d,%4d,%4d,%4d,%4d,%4d,%4d, /* O-U */\n", 05565 idx_tbl[14],idx_tbl[15],idx_tbl[16],idx_tbl[17], 05566 idx_tbl[18],idx_tbl[19],idx_tbl[20]); 05567 printf("\t\t\t\t%3d,%4d,%4d,%4d,%4d, /* V-Z */\n", 05568 idx_tbl[21],idx_tbl[22],idx_tbl[23],idx_tbl[24], 05569 idx_tbl[25]); 05570 printf("\t\t\t\t%3d }; /* end */\n", 05571 idx_tbl[26]); 05572 # endif 05573 05574 05575 TRACE (Func_Exit, "set_up_letter_idx_table", NULL); 05576 05577 return; 05578 05579 } /* set_up_letter_idx_table */