lex.c

Go to the documentation of this file.
00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2 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(