Open64: osprey/crayf90/fe90/s_intrin.c Source File

00001 /*
00002  * Copyright (C) 2008. PathScale, LLC. All Rights Reserved.
00003  */
00004 /*
00005  *  Copyright (C) 2006, 2007. QLogic Corporation. All Rights Reserved.
00006  */
00007 
00008 /*
00009  * Copyright 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
00010  */
00011 
00012 /*
00013 
00014   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00015 
00016   This program is free software; you can redistribute it and/or modify it
00017   under the terms of version 2 of the GNU General Public License as
00018   published by the Free Software Foundation.
00019 
00020   This program is distributed in the hope that it would be useful, but
00021   WITHOUT ANY WARRANTY; without even the implied warranty of
00022   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00023 
00024   Further, this software is distributed without any warranty that it is
00025   free of the rightful claim of any third person regarding infringement 
00026   or the like.  Any license provided herein, whether implied or 
00027   otherwise, applies only to this software file.  Patent licenses, if 
00028   any, provided herein do not apply to combinations of this program with 
00029   other software, or any other product whatsoever.  
00030 
00031   You should have received a copy of the GNU General Public License along
00032   with this program; if not, write the Free Software Foundation, Inc., 59
00033   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00034 
00035   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00036   Mountain View, CA 94043, or:
00037 
00038   http://www.sgi.com
00039 
00040   For further information regarding this notice, see:
00041 
00042   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00043 
00044 */
00045 
00046 
00047 
00048 static char USMID[] = "\n@(#)5.0_pl/sources/s_intrin.c  5.31  10/27/99 16:50:34\n";
00049 
00050 # include "defines.h"   /* Machine dependent ifdefs */
00051 # include "host.m"    /* Host machine dependent macros.*/
00052 # include "host.h"    /* Host machine dependent header.*/
00053 # include "target.m"    /* Target machine dependent macros.*/
00054 # include "target.h"    /* Target machine dependent header.*/
00055 # include "globals.m"
00056 # include "tokens.m"
00057 # include "sytb.m"
00058 # include "s_globals.m"
00059 # include "debug.m"
00060 # include "fmath.h"
00061 # include "globals.h"
00062 # include "tokens.h"
00063 # include "sytb.h"
00064 # include "s_globals.h"
00065 
00066 # if defined(_HOST_OS_UNICOS) || defined(_HOST_OS_MAX)
00067 # include <fortran.h>
00068 # endif
00069 
00070 
00071 extern boolean has_present_opr;
00072 #ifdef KEY /* Bug 5089 */
00073 #ifdef TARG_X8664
00074 extern boolean Target_SSE2;
00075 extern boolean Target_SSE3;
00076 #endif
00077 #endif /* KEY Bug 5089 */
00078 
00079 #ifdef KEY /* Bug 10410 */
00080 /*
00081  * list_idx IL_Tbl_Idx for an actual argument of the intrinsic call
00082  * return attr_idx if in this call, an optional dummy argument belonging to the
00083  *    caller is being passed as the actual argument of the intrinsic call; or
00084  *    return NULL_IDX otherwise
00085  */
00086 static int
00087 is_optional_dummy(int list_idx) {
00088   if (list_idx == NULL_IDX || IL_IDX(list_idx) == NULL_IDX) {
00089     return FALSE;
00090     }
00091   if (IL_FLD(list_idx) == AT_Tbl_Idx) {
00092     return AT_OPTIONAL(IL_IDX(list_idx));
00093     }
00094   int ignore_line, ignore_col;
00095   int attr_idx = find_base_attr(&IL_OPND(list_idx), &ignore_line, &ignore_col);
00096   return (attr_idx != NULL_IDX && AT_OPTIONAL(attr_idx)) ? attr_idx : NULL_IDX;
00097   }
00098 
00099 /*
00100  * Generate a Cselect_Opr using "present(dummy)" as its predicate. This is
00101  * useful when an optional dummy argument is used as the actual argument
00102  * for a call to an intrinsic. We use this when we need to choose whether to
00103  * pass the dummy argument or a default value to the intrinsic, and also when
00104  * we need to choose between two different forms of calling the intrinsic.
00105  *
00106  * line     Line number for intrinsic call
00107  * col      Column number for intrinsic call
00108  * dummy_idx    AT_Tbl_Idx index for optional dummy argument
00109  * true_fld   fld_type for true_idx
00110  * true_idx   Index for true part of Cselect_Opr
00111  * false_fld    fld_type for false_idx
00112  * false_idx    Index for false part of Cselect_Opr
00113  * result_type_idx  Index for result type of Cselect_Opr
00114  * return   Index in IL_Tbl_Idx for Cselect_Opr
00115  */
00116 static boolean
00117 gen_select_present(int line, int col, int dummy_idx,
00118   fld_type true_fld, int true_idx,
00119   fld_type false_fld, int false_idx,
00120   int result_type_idx) {
00121   int present_idx = gen_ir(AT_Tbl_Idx, dummy_idx,
00122     Present_Opr, CG_LOGICAL_DEFAULT_TYPE, line, col,
00123     NO_Tbl_Idx, NULL_IDX);
00124   int select_arglist_idx = gen_il(3, TRUE, line, col,
00125     true_fld, true_idx,
00126     false_fld, false_idx,
00127     IR_Tbl_Idx, present_idx);
00128   int select_idx = gen_ir(IL_Tbl_Idx, select_arglist_idx,
00129     Cselect_Opr,
00130     result_type_idx, line, col,
00131     NO_Tbl_Idx, NULL_IDX);
00132   return select_idx;
00133   }
00134 
00135 /*
00136  * When a caller is passing an optional dummy argument as the actual argument
00137  * in a call to an intrinsic, replace the dummy argument "d" with a "select"
00138  * expression, e.g. "(present(attr_idx) ? list_idx : default)".
00139  * list_idx IL_Tbl_Idx for the optional dummy argument which is being
00140  *    passed as the actual argument
00141  * default_fld  fld_type for default_idx
00142  * default_idx  Index for a value to be used if the optional argument
00143  *    is not present
00144  * default_type_idx Type index for default value
00145  * need_temp  Store the constant into a compiler temp and pass that (needed
00146  *    for call-by-reference)
00147  */
00148 static void
00149 pass_dummy_or_default(int list_idx, fld_type default_fld, int default_idx,
00150   int default_type_idx, boolean need_temp) {
00151   int ignore_line, ignore_col;
00152   int attr_idx = find_base_attr(&IL_OPND(list_idx), &ignore_line, &ignore_col);
00153   int select_idx =
00154     gen_select_present(IL_LINE_NUM(list_idx), IL_COL_NUM(list_idx), attr_idx,
00155       IL_FLD(list_idx), IL_IDX(list_idx),
00156       default_fld, default_idx, default_type_idx);
00157   int line = IL_LINE_NUM(list_idx);
00158   int col = IL_COL_NUM(list_idx);
00159   if (need_temp) {
00160     int tmp_attr = gen_compiler_tmp(line, col, Priv, TRUE);
00161     int cn_type_idx = ATD_TYPE_IDX(tmp_attr) = CN_TYPE_IDX(default_idx);
00162     ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx);
00163     AT_SEMANTICS_DONE(tmp_attr) = TRUE;
00164     int asg_idx = gen_ir(AT_Tbl_Idx, tmp_attr, Asg_Opr, cn_type_idx, line, col,
00165       IR_Tbl_Idx, select_idx);
00166     gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
00167     SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
00168     IL_FLD(list_idx) = AT_Tbl_Idx;
00169     IL_IDX(list_idx) = tmp_attr;
00170     }
00171   else {
00172     IL_FLD(list_idx) = IR_Tbl_Idx;
00173     IL_IDX(list_idx) = select_idx;
00174     }
00175 }
00176 
00177 /* Like pass_dummy_or_default, but default must be constant */
00178 static void
00179 pass_dummy_or_default_const(int list_idx, int default_idx, boolean need_temp) {
00180   pass_dummy_or_default(list_idx, CN_Tbl_Idx, default_idx,
00181     CN_TYPE_IDX(default_idx), need_temp);
00182   }
00183 #endif /* KEY Bug 10410 */
00184 #ifdef KEY /* Bug 12482 */
00185 /*
00186  * When a call to the REAL intrinsic is given a typeless constant argument,
00187  * use this function to convert the typeless value to an integer or a real
00188  * bit pattern
00189  *
00190  * list_idx1  IL_Tbl_Idx for first (A) argument, assumed typeless
00191  * list_idx2  IL_Tbl_Idx for second (KIND) argument, or NULL_IDX
00192  */
00193 static void
00194 typeless_to_type(int list_idx1, Uint result_type_idx) {
00195   long_type dst[MAX_WORDS_FOR_INTEGER];
00196   memset(dst, 0, MAX_WORDS_FOR_INTEGER * sizeof *dst);
00197   long_type *src = (long_type *) &CN_CONST(IL_IDX(list_idx1));
00198   int info_idx1 = IL_ARG_DESC_IDX(list_idx1);
00199   Uint src_type_idx = arg_info_list[info_idx1].ed.type_idx;
00200   int src_len = TYP_BIT_LEN(src_type_idx) / TARGET_BITS_PER_WORD;
00201 
00202   /* F2003 treats boz constant as giant integer, creates real having same
00203    * bit pattern; but g77 treats typeless constant as integer, generating
00204    * a real having the same magnitude. Our strategy is to create a new
00205    * constant having an integer or real type, copying into it the original
00206    * bit pattern padded or truncated to fit that type, and let the "real"
00207    * intrinsic operate on that constant. */
00208   if (!(on_off_flags.issue_ansi_messages || on_off_flags.fortran2003)) {
00209     result_type_idx = Integer_8;
00210     }
00211   linear_type_type result_linear_type = TYP_LINEAR(result_type_idx);
00212   int dst_len = num_host_wds[result_linear_type];
00213 
00214   copy_and_pad_boz(dst, dst_len, src, src_len);
00215   IL_IDX(list_idx1) = ntr_const_tbl(result_type_idx, TRUE, dst);
00216 }
00217 #endif /* KEY Bug 12482 */
00218 
00219 
00220 /******************************************************************************\
00221 |*                                                                            *|
00222 |* Description:                                                               *|
00223 |*      generate an array constructor of lower and upper bounds from a bd ntry*|
00224 |*                                                                            *|
00225 |* Input parameters:                                                          *|
00226 |*      NONE                                                                  *|
00227 |*                                                                            *|
00228 |* Output parameters:                                                         *|
00229 |*      NONE                                                                  *|
00230 |*                                                                            *|
00231 |* Returns:                                                                   *|
00232 |*      NOTHING                                                               *|
00233 |*                                                                            *|
00234 \******************************************************************************/
00235 
00236 static void generate_bounds_list(int            bd_idx,
00237                                  opnd_type      *result_opnd,
00238                                  expr_arg_type  *exp_desc)
00239 
00240 {
00241 
00242    int                  col;
00243    int                  i;
00244    int                  ir_idx;
00245    int                  line;
00246    int                  list_idx = NULL_IDX;
00247    opnd_type            opnd;
00248    cif_usage_code_type  save_xref_state;
00249 
00250 
00251    TRACE (Func_Entry, "generate_bounds_list", NULL);
00252 
00253    find_opnd_line_and_column(result_opnd, &line, &col);
00254 
00255    NTR_IR_TBL(ir_idx);
00256    IR_OPR(ir_idx) = Array_Construct_Opr;
00257    IR_LINE_NUM(ir_idx) = line;
00258    IR_COL_NUM(ir_idx) = col;
00259 
00260    IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00261    IR_LIST_CNT_R(ir_idx) = 2 * BD_RANK(bd_idx);
00262 
00263 
00264    for (i = 1; i <= BD_RANK(bd_idx); i++) {
00265       if (list_idx == NULL_IDX) {
00266          NTR_IR_LIST_TBL(list_idx);
00267          IR_IDX_R(ir_idx) = list_idx;
00268       }
00269       else {
00270          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00271          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00272          list_idx = IL_NEXT_LIST_IDX(list_idx);
00273       }
00274 
00275       IL_FLD(list_idx) = BD_LB_FLD(bd_idx, i);
00276       IL_IDX(list_idx) = BD_LB_IDX(bd_idx, i);
00277       IL_LINE_NUM(list_idx) = line;
00278       IL_COL_NUM(list_idx) = col;
00279 
00280       COPY_OPND(opnd, IL_OPND(list_idx));
00281       cast_opnd_to_type_idx(&opnd, CG_INTEGER_DEFAULT_TYPE);
00282       COPY_OPND(IL_OPND(list_idx), opnd);
00283 
00284       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00285       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00286       list_idx = IL_NEXT_LIST_IDX(list_idx);
00287 
00288       if (BD_ARRAY_CLASS(bd_idx) == Assumed_Size &&
00289           i == BD_RANK(bd_idx)) {
00290 
00291          IL_FLD(list_idx) = CN_Tbl_Idx;
00292          IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
00293       }
00294       else {
00295          IL_FLD(list_idx) = BD_UB_FLD(bd_idx, i);
00296          IL_IDX(list_idx) = BD_UB_IDX(bd_idx, i);
00297       }
00298 
00299       IL_LINE_NUM(list_idx) = line;
00300       IL_COL_NUM(list_idx) = col;
00301 
00302       COPY_OPND(opnd, IL_OPND(list_idx));
00303       cast_opnd_to_type_idx(&opnd, CG_INTEGER_DEFAULT_TYPE);
00304       COPY_OPND(IL_OPND(list_idx), opnd);
00305    }
00306 
00307    save_xref_state = xref_state;
00308    xref_state = CIF_No_Usage_Rec;
00309    OPND_FLD((*result_opnd)) = IR_Tbl_Idx;
00310    OPND_IDX((*result_opnd)) = ir_idx;
00311    exp_desc->rank = 0;
00312    expr_semantics(result_opnd, exp_desc);
00313    xref_state = save_xref_state;
00314 
00315    TRACE (Func_Exit, "generate_bounds_list", NULL);
00316 
00317    return;
00318 
00319 }  /* generate_bounds_list */
00320 
00321 
00322 
00323 /******************************************************************************\
00324 |*                        *|
00325 |* Description:                     *|
00326 |*  <description>                   *|
00327 |*                        *|
00328 |* Input parameters:                    *|
00329 |*  NONE                      *|
00330 |*                        *|
00331 |* Output parameters:                   *|
00332 |*  NONE                      *|
00333 |*                        *|
00334 |* Returns:                     *|
00335 |*  NOTHING                     *|
00336 |*                        *|
00337 \******************************************************************************/
00338 
00339 static int cri_ptr_type(int type_idx)
00340 
00341 {
00342    int    ptr_type;
00343 
00344 
00345    TRACE (Func_Entry, "cri_ptr_type", NULL);
00346 
00347    ptr_type = CRI_Ptr_8;
00348 
00349 # ifdef _TRANSFORM_CHAR_SEQUENCE
00350    if (TYP_TYPE(type_idx) == Character ||
00351        (TYP_TYPE(type_idx) == Structure &&
00352         ATT_CHAR_SEQ(TYP_IDX(type_idx))))
00353 # else
00354    if (TYP_TYPE(type_idx) == Character)
00355 # endif
00356                                           {
00357 
00358       ptr_type = CRI_Ch_Ptr_8;
00359    }
00360 # ifdef _TARGET32
00361    else if (TARGET_32BIT_DOUBLE_WORD_STORAGE_TYPE(type_idx) ||
00362             TYP_LINEAR(type_idx) == Complex_4) {
00363 
00364       CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00365       TYP_TYPE(TYP_WORK_IDX)                    = CRI_Ptr;
00366       TYP_LINEAR(TYP_WORK_IDX)                  = CRI_Ptr_8;
00367       TYP_PTR_INCREMENT(TYP_WORK_IDX)           = 64;
00368       ptr_type  = ntr_type_tbl();
00369 
00370    }
00371 # endif
00372 
00373 # ifdef _TARGET_OS_MAX
00374    else if (TARGET_MAX_HALF_WORD_STORAGE_TYPE(type_idx)) {
00375 
00376       CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
00377       TYP_TYPE(TYP_WORK_IDX)                    = CRI_Ptr;
00378       TYP_LINEAR(TYP_WORK_IDX)                  = CRI_Ptr_8;
00379       TYP_PTR_INCREMENT(TYP_WORK_IDX)           = 32;
00380       ptr_type  = ntr_type_tbl();
00381    }
00382 # endif
00383 
00384 
00385    TRACE (Func_Exit, "cri_ptr_type", NULL);
00386 
00387    return(ptr_type);
00388 
00389 }  /* cri_ptr_type */
00390 
00391 
00392 /******************************************************************************\
00393 |*                        *|
00394 |* Description:                     *|
00395 |*  <description>                   *|
00396 |*                        *|
00397 |* Input parameters:                    *|
00398 |*  NONE                      *|
00399 |*                        *|
00400 |* Output parameters:                   *|
00401 |*  NONE                      *|
00402 |*                        *|
00403 |* Returns:                     *|
00404 |*  NOTHING                     *|
00405 |*                        *|
00406 \******************************************************************************/
00407 
00408 #if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00409 #if COMPILER_VERSION < 730
00410 static void dummydummydummy(void *a, void *b){}
00411 #endif
00412 #endif
00413 
00414 static boolean optimize_reshape(opnd_type *result_opnd,
00415               expr_arg_type *res_exp_desc)
00416 
00417 {
00418    int      asg_idx;
00419    int      attr_idx;
00420    int      bd_idx;
00421    int      col;
00422    expr_arg_type  exp_desc1;
00423    expr_arg_type  exp_desc2;
00424    expr_arg_type  exp_desc4;
00425    long     i;
00426    int      info_idx1;
00427    int      info_idx2;
00428    int      info_idx4;
00429    int      ir_idx;
00430    int      line;
00431    int      list_idx1;
00432    int      list_idx2;
00433    int      list_idx3;
00434    int      list_idx4;
00435    expr_arg_type  loc_exp_desc;
00436    int      loc_idx;
00437    opnd_type    l_opnd;
00438    boolean    ok;
00439    opnd_type    opnd;
00440    boolean    optimized = FALSE;
00441    boolean    equal     = TRUE;
00442    int      ptee_idx;
00443    int      ptr_idx;
00444    opnd_type    r_opnd;
00445    int      type_idx;
00446    int      unused1;
00447    int      unused2;
00448 
00449 
00450    TRACE (Func_Entry, "optimize_reshape", NULL);
00451 
00452    if (OPND_FLD((*result_opnd)) == IR_Tbl_Idx &&
00453        IR_OPR(OPND_IDX((*result_opnd))) == Call_Opr) {
00454 
00455       ir_idx = OPND_IDX((*result_opnd));
00456 
00457       list_idx1 = IR_IDX_R(ir_idx);
00458       list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
00459       list_idx3 = IL_NEXT_LIST_IDX(list_idx2);
00460       list_idx4 = IL_NEXT_LIST_IDX(list_idx3);
00461 
00462       info_idx1 = IL_ARG_DESC_IDX(list_idx1);
00463       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
00464 
00465 #if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00466 #if COMPILER_VERSION < 730
00467       /* Work around 7.2.1.2 optimizer bug */
00468       dummydummydummy(&info_idx1,&info_idx2);
00469 #endif
00470 #endif
00471 
00472       exp_desc1 = arg_info_list[info_idx1].ed;
00473       exp_desc2 = arg_info_list[info_idx2].ed;
00474  
00475       if (IL_FLD(list_idx4) != NO_Tbl_Idx) {
00476          info_idx4 = IL_ARG_DESC_IDX(list_idx4);
00477          exp_desc4 = arg_info_list[info_idx4].ed;
00478 
00479          if (exp_desc4.foldable) {
00480 
00481             attr_idx = find_base_attr(&IL_OPND(list_idx4), &line, &col);
00482             loc_exp_desc = init_exp_desc;
00483             loc_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx);
00484             loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
00485             loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx);
00486 
00487             loc_exp_desc.foldable = TRUE;
00488             loc_exp_desc.constant = TRUE;
00489 
00490             for (i = 1; i <= res_exp_desc->rank; i++) {
00491                change_section_to_this_element(&IL_OPND(list_idx4),
00492                                               &opnd,
00493                                               i);
00494 
00495                ok = fold_aggragate_expression(&opnd,
00496                                               &loc_exp_desc,
00497                                               TRUE);
00498 
00499                equal = equal && compare_cn_and_value(OPND_IDX(opnd), i, Eq_Opr);
00500             }
00501 
00502             if (equal && compare_cn_and_value(OPND_IDX(exp_desc4.shape[0]), 
00503                                               (long) res_exp_desc->rank, 
00504                                               Eq_Opr)) {
00505                IL_OPND(list_idx4) = null_opnd;   
00506             }
00507          }
00508 
00509       }
00510 
00511       if (IL_FLD(list_idx3) == NO_Tbl_Idx &&
00512           IL_FLD(list_idx4) == NO_Tbl_Idx) {
00513 
00514          if (exp_desc1.reference    ||
00515              exp_desc1.tmp_reference) {
00516 
00517             if (! exp_desc1.contig_array) {
00518                goto EXIT;
00519             }
00520 
00521             attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col);
00522 
00523             if (ATD_POINTER(attr_idx)) {
00524                goto EXIT;
00525             }
00526 
00527             if (ATD_ARRAY_IDX(attr_idx) &&
00528                 BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) == Assumed_Shape) {
00529                goto EXIT;
00530             }
00531          }
00532          else {
00533             /* not a reference, this would be a copy in anyway */
00534 
00535             COPY_OPND(r_opnd, IL_OPND(list_idx1));
00536             attr_idx = create_tmp_asg(&r_opnd,
00537                                       &exp_desc1,
00538                                       &l_opnd,
00539                                       Intent_In,
00540                                       FALSE,
00541                                       FALSE);
00542 
00543             COPY_OPND(IL_OPND(list_idx1), l_opnd);
00544             arg_info_list[info_idx1].ed = exp_desc1;
00545          }
00546               
00547 
00548          if (! exp_desc2.reference &&
00549              ! exp_desc2.tmp_reference) {
00550 
00551             COPY_OPND(r_opnd, IL_OPND(list_idx2));
00552             attr_idx = create_tmp_asg(&r_opnd,
00553                                       &exp_desc2,
00554                                       &l_opnd,
00555                                       Intent_In,
00556                                       FALSE,
00557                                       FALSE);
00558 
00559             COPY_OPND(IL_OPND(list_idx2), l_opnd);
00560             arg_info_list[info_idx2].ed = exp_desc2;
00561          }
00562 
00563          attr_idx = find_base_attr(&IL_OPND(list_idx2), &line, &col);
00564          loc_exp_desc = init_exp_desc;
00565          loc_exp_desc.type_idx = ATD_TYPE_IDX(attr_idx);
00566          loc_exp_desc.type = TYP_TYPE(loc_exp_desc.type_idx);
00567          loc_exp_desc.linear_type = TYP_LINEAR(loc_exp_desc.type_idx);
00568 
00569          if (exp_desc2.foldable) {
00570             loc_exp_desc.foldable = TRUE;
00571             loc_exp_desc.constant = TRUE;
00572          }
00573 
00574          for (i = 1; i <= res_exp_desc->rank; i++) {
00575 
00576             change_section_to_this_element(&IL_OPND(list_idx2),
00577                                            &opnd,
00578                                            i);
00579             if (exp_desc2.foldable) {
00580                ok = fold_aggragate_expression(&opnd,
00581                                               &loc_exp_desc,
00582                                               TRUE);
00583             }
00584 
00585             COPY_OPND(res_exp_desc->shape[i-1], opnd);
00586          }
00587 
00588          if (gen_bd_entry(NULL, res_exp_desc, &bd_idx, line, col)) {
00589             /* intentionally blank */
00590          }
00591    
00592          type_idx = cri_ptr_type(exp_desc1.type_idx);
00593 
00594          /* generate the ptr/pointee pair */
00595 
00596          ptr_idx  = gen_compiler_tmp(line, col, Shared, TRUE);
00597          ATD_TYPE_IDX(ptr_idx) = type_idx;
00598          AT_SEMANTICS_DONE(ptr_idx) = TRUE;
00599          ATD_STOR_BLK_IDX(ptr_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
00600 
00601          ptee_idx = gen_compiler_tmp(line, col, Shared, TRUE);
00602          ATD_CLASS(ptee_idx) = CRI__Pointee;
00603          AT_SEMANTICS_DONE(ptee_idx) = TRUE;
00604          ATD_STOR_BLK_IDX(ptee_idx) = SCP_SB_BASED_IDX(curr_scp_idx);
00605          ATD_TYPE_IDX(ptee_idx) = exp_desc1.type_idx;
00606          ATD_ARRAY_IDX(ptee_idx) = bd_idx;
00607          ATD_PTR_IDX(ptee_idx) = ptr_idx;
00608 
00609          /* generate assignment to ptr */
00610 
00611          attr_idx = find_base_attr(&IL_OPND(list_idx1), &unused1, &unused2);
00612 
00613 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00614          if (AT_OBJ_CLASS(attr_idx) == Data_Obj) {
00615             ATD_NOT_PT_UNIQUE_MEM(attr_idx) = TRUE;
00616          }
00617 # endif
00618 
00619          if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
00620              ATD_CLASS(attr_idx) == Compiler_Tmp &&
00621              exp_desc1.type != Character &&
00622              ATD_IM_A_DOPE(attr_idx)) {
00623 
00624             asg_idx = gen_ir(AT_Tbl_Idx, ptr_idx,
00625                          Asg_Opr, type_idx, line, col,
00626                              IR_Tbl_Idx, gen_ir(AT_Tbl_Idx, attr_idx,
00627                                            Dv_Access_Base_Addr,
00628                                              SA_INTEGER_DEFAULT_TYPE,line,col,
00629                                                 NO_Tbl_Idx, NULL_IDX));
00630 
00631          }
00632          else {
00633 
00634          COPY_OPND(opnd, IL_OPND(list_idx1));
00635          unused1 = NULL_IDX;
00636          unused2 = NULL_IDX;
00637          make_base_subtree(&opnd, &r_opnd, &unused1, &unused2);
00638 
00639          loc_idx = gen_ir(OPND_FLD(r_opnd), OPND_IDX(r_opnd),
00640                       Loc_Opr, type_idx, line, col,
00641                           NO_Tbl_Idx, NULL_IDX);
00642 
00643 # ifdef _TRANSFORM_CHAR_SEQUENCE
00644          if (exp_desc1.type == Structure &&
00645              ATT_CHAR_SEQ(TYP_IDX(exp_desc1.type_idx))) {
00646 
00647             COPY_OPND(opnd, IR_OPND_L(loc_idx));
00648             transform_char_sequence_ref(&opnd, exp_desc1.type_idx);
00649             COPY_OPND(IR_OPND_L(loc_idx), opnd);
00650          }
00651 # endif
00652 
00653          asg_idx = gen_ir(AT_Tbl_Idx, ptr_idx,
00654                       Asg_Opr, type_idx, line, col,
00655                           IR_Tbl_Idx, loc_idx);
00656 
00657          }
00658          
00659          gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
00660 
00661          SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
00662          SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
00663 
00664          gen_opnd(result_opnd, ptee_idx, AT_Tbl_Idx, line, col);
00665 
00666          res_exp_desc->tmp_reference = TRUE;
00667          ok = gen_whole_subscript(result_opnd, res_exp_desc);
00668 
00669          optimized = TRUE;
00670       }
00671    }
00672 
00673 EXIT:
00674 
00675    TRACE (Func_Exit, "optimize_reshape", NULL);
00676 
00677    return(optimized);
00678 
00679 }  /* optimize_reshape */
00680 
00681 
00682 /******************************************************************************\
00683 |*                                                                            *|
00684 |* Description:                                                               *|
00685 |*      Check conformance of the operands to an elemental intrinsic.          *|
00686 |*      Also, return the index of the argument to extract the rank/shape from.*|
00687 |*                                                                            *|
00688 |* Input parameters:                                                          *|
00689 |*      NONE                                                                  *|
00690 |*                                                                            *|
00691 |* Output parameters:                                                         *|
00692 |*      NONE                                                                  *|
00693 |*                                                                            *|
00694 |* Returns:                                                                   *|
00695 |*      NOTHING                                                               *|
00696 |*                                                                            *|
00697 \******************************************************************************/
00698 
00699 void   conform_check(int           check_args,
00700                      int           ir_idx,
00701                      expr_arg_type *res_exp_desc,
00702                      int           *spec_idx,
00703          boolean     assumed_size_allowed)
00704 {
00705    int            line;
00706    int            col;
00707 #ifdef KEY /* Bug 10177 */
00708    int            which_arg = 0;
00709 #else /* KEY Bug 10177 */
00710    int            which_arg;
00711 #endif /* KEY Bug 10177 */
00712    int            max_rank;
00713    int            attr_idx;
00714    int      temp_ir_idx;
00715    int            i;
00716    int      info_idx;
00717 
00718 
00719    TRACE (Func_Entry, "conform_check", NULL);
00720 
00721    max_rank = 0;
00722  
00723    temp_ir_idx = IR_IDX_R(ir_idx);
00724 
00725    if (temp_ir_idx != NULL_IDX) {  /* are there any arguments */
00726       which_arg = IL_ARG_DESC_IDX(temp_ir_idx);
00727    }
00728 
00729    res_exp_desc->will_fold_later = TRUE;
00730    res_exp_desc->foldable = TRUE;
00731 
00732    for (i = 1; i <= IR_LIST_CNT_R(ir_idx); i++) {
00733 
00734        if (IL_FLD(temp_ir_idx) == NO_Tbl_Idx) {
00735           temp_ir_idx = IL_NEXT_LIST_IDX(temp_ir_idx);
00736           continue;
00737        }
00738 
00739        info_idx = IL_ARG_DESC_IDX(temp_ir_idx);
00740 
00741        if (! assumed_size_allowed &&
00742            arg_info_list[info_idx].ed.rank != 0 &&
00743            (IL_FLD(temp_ir_idx) == AT_Tbl_Idx ||
00744             (IL_FLD(temp_ir_idx) == IR_Tbl_Idx &&
00745              IR_OPR(IL_IDX(temp_ir_idx)) == Whole_Substring_Opr &&
00746              IR_FLD_L(IL_IDX(temp_ir_idx)) == AT_Tbl_Idx))) {
00747 
00748            PRINTMSG(arg_info_list[info_idx].line, 412, Error,
00749                     arg_info_list[info_idx].col);
00750        }
00751 
00752        attr_idx = 0;
00753        if ((IL_FLD(temp_ir_idx) == IR_Tbl_Idx) &&
00754           ((IR_OPR(IL_IDX(temp_ir_idx)) == Whole_Subscript_Opr) ||
00755            (IR_OPR(IL_IDX(temp_ir_idx)) == Section_Subscript_Opr))) {
00756           attr_idx = find_base_attr(&IL_OPND(temp_ir_idx), &line, &col);
00757        }
00758 
00759        if ((check_args != 0) &&
00760            (i >= check_args) &&
00761            (arg_info_list[info_idx].ed.rank != max_rank) &&
00762            (attr_idx != 0) &&
00763            (!(ATP_INTRIN_ENUM(*spec_idx) == Present_Intrinsic)) &&
00764            (AT_OPTIONAL(attr_idx))) {
00765            PRINTMSG(arg_info_list[info_idx].line, 947,  Error, 
00766                     arg_info_list[info_idx].col);
00767        }
00768 
00769        if (!arg_info_list[info_idx].ed.foldable && 
00770            !arg_info_list[info_idx].ed.will_fold_later) {
00771           res_exp_desc->will_fold_later = FALSE;
00772        }
00773 
00774        if (! arg_info_list[info_idx].ed.foldable) {
00775           res_exp_desc->foldable = FALSE;
00776        }
00777 
00778        if (max_rank != 0 &&       
00779            AT_ELEMENTAL_INTRIN(*spec_idx) &&
00780            arg_info_list[info_idx].ed.rank != 0 &&
00781            max_rank != arg_info_list[info_idx].ed.rank) {
00782           PRINTMSG(arg_info_list[info_idx].line, 363,  Error, 
00783                    arg_info_list[info_idx].col);
00784        }
00785 
00786        if (arg_info_list[info_idx].ed.rank > max_rank) {
00787           max_rank = arg_info_list[info_idx].ed.rank;
00788           which_arg = info_idx;
00789        }
00790 
00791        temp_ir_idx = IL_NEXT_LIST_IDX(temp_ir_idx);
00792    }
00793 
00794    if (ATP_PGM_UNIT(*spec_idx) != Subroutine) {
00795       res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
00796       res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
00797       res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
00798    }
00799    res_exp_desc->rank = max_rank;
00800 
00801    if (max_rank > 0 && AT_ELEMENTAL_INTRIN(*spec_idx))  {
00802       COPY_SHAPE(res_exp_desc->shape,
00803                  arg_info_list[which_arg].ed.shape,
00804                  arg_info_list[which_arg].ed.rank);
00805    }
00806 
00807    TRACE (Func_Exit, "conform_check", NULL);
00808 
00809 }  /* conform_check */
00810 
00811 
00812 /******************************************************************************\
00813 |*                                                                            *|
00814 |* Description:                                                               *|
00815 |*      Function    SIN(X) intrinsic.                                         *|
00816 |*      Function    DSIN(X) intrinsic.                                        *|
00817 |*      Function    QSIN(X) intrinsic.                                        *|
00818 |*      Function    CSIN(X) intrinsic.                                        *|
00819 |*      Function    CDSIN(X) intrinsic.                                       *|
00820 |*      Function    CQSIN(X) intrinsic.                                       *|
00821 |*      Function    SIND(X) intrinsic.                                        *|
00822 |*      Function    DSIND(X) intrinsic.                                       *|
00823 |*      Function    QSIND(X) intrinsic.                                       *|
00824 |*      Function    SINH(X) intrinsic.                                        *|
00825 |*      Function    DSINH(X) intrinsic.                                       *|
00826 |*      Function    QSINH(X) intrinsic.                                       *|
00827 |*      Function    ASIN(X) intrinsic.                                        *|
00828 |*      Function    DASIN(X) intrinsic.                                       *|
00829 |*      Function    QASIN(X) intrinsic.                                       *|
00830 |*      Function    ASIND(X) intrinsic.                                       *|
00831 |*      Function    DASIND(X) intrinsic.                                      *|
00832 |*      Function    QASIND(X) intrinsic.                                      *|
00833 |*      Function    COS(X) intrinsic.                                         *|
00834 |*      Function    DCOS(X) intrinsic.                                        *|
00835 |*      Function    QCOS(X) intrinsic.                                        *|
00836 |*      Function    CCOS(X) intrinsic.                                        *|
00837 |*      Function    CDCOS(X) intrinsic.                                       *|
00838 |*      Function    CQCOS(X) intrinsic.                                       *|
00839 |*      Function    COSD(X) intrinsic.                                        *|
00840 |*      Function    DCOSD(X) intrinsic.                                       *|
00841 |*      Function    QCOSD(X) intrinsic.                                       *|
00842 |*      Function    COSH(X) intrinsic.                                        *|
00843 |*      Function    DCOSH(X) intrinsic.                                       *|
00844 |*      Function    QCOSH(X) intrinsic.                                       *|
00845 |*      Function    ACOS(X) intrinsic.                                        *|
00846 |*      Function    DACOS(X) intrinsic.                                       *|
00847 |*      Function    QACOS(X) intrinsic.                                       *|
00848 |*      Function    ACOSD(X) intrinsic.                                       *|
00849 |*      Function    DACOSD(X) intrinsic.                                      *|
00850 |*      Function    QACOSD(X) intrinsic.                                      *|
00851 |*      Function    TAN(X) intrinsic.                                         *|
00852 |*      Function    DTAN(X) intrinsic.                                        *|
00853 |*      Function    QTAN(X) intrinsic.                                        *|
00854 |*      Function    TAND(X) intrinsic.                                        *|
00855 |*      Function    DTAND(X) intrinsic.                                       *|
00856 |*      Function    QTAND(X) intrinsic.                                       *|
00857 |*      Function    TANH(X) intrinsic.                                        *|
00858 |*      Function    DTANH(X) intrinsic.                                       *|
00859 |*      Function    QTANH(X) intrinsic.                                       *|
00860 |*      Function    ATAN(X) intrinsic.                                        *|
00861 |*      Function    DATAN(X) intrinsic.                                       *|
00862 |*      Function    QATAN(X) intrinsic.                                       *|
00863 |*      Function    ATAND(X) intrinsic.                                       *|
00864 |*      Function    DATAND(X) intrinsic.                                      *|
00865 |*      Function    QATAND(X) intrinsic.                                      *|
00866 |*      Function    LOG(X) intrinsic.                                         *|
00867 |*      Function    DLOG(X) intrinsic.                                        *|
00868 |*      Function    QLOG(X) intrinsic.                                        *|
00869 |*      Function    CDLOG(X) intrinsic.                                       *|
00870 |*      Function    CQLOG(X) intrinsic.                                       *|
00871 |*      Function    LOG10(X) intrinsic.                                       *|
00872 |*      Function    DLOG10(X) intrinsic.                                      *|
00873 |*      Function    QLOG10(X) intrinsic.                                      *|
00874 |*      Function    EXP(X) intrinsic.                                         *|
00875 |*      Function    DEXP(X) intrinsic.                                        *|
00876 |*      Function    QEXP(X) intrinsic.                                        *|
00877 |*      Function    CEXP(X) intrinsic.                                        *|
00878 |*      Function    CDEXP(X) intrinsic.                                       *|
00879 |*      Function    CQEXP(X) intrinsic.                                       *|
00880 |*      Function    COT(X) intrinsic.                                         *|
00881 |*      Function    DCOT(X) intrinsic.                                        *|
00882 |*      Function    QCOT(X) intrinsic.                                        *|
00883 |*      Function    SQRT(X) intrinsic.                                        *|
00884 |*      Function    DSQRT(X) intrinsic.                                       *|
00885 |*      Function    QSQRT(X) intrinsic.                                       *|
00886 |*      Function    CSQRT(X) intrinsic.                                       *|
00887 |*      Function    CDSQRT(X) intrinsic.                                      *|
00888 |*      Function    CQSQRT(X) intrinsic.                                      *|
00889 |*                                                                            *|
00890 |* Input parameters:                                                          *|
00891 |*      NONE                                                                  *|
00892 |*                                                                            *|
00893 |* Output parameters:                                                         *|
00894 |*      NONE                                                                  *|
00895 |*                                                                            *|
00896 |* Returns:                                                                   *|
00897 |*      NOTHING                                                               *|
00898 |*                                                                            *|
00899 \******************************************************************************/
00900 
00901 void    sin_intrinsic(opnd_type     *result_opnd,
00902                       expr_arg_type *res_exp_desc,
00903                       int           *spec_idx)
00904 {
00905 
00906    int    info_idx1;
00907    int    list_idx1;
00908    int    ir_idx;
00909 
00910 
00911    TRACE (Func_Entry, "sin_intrinsic", NULL);
00912 
00913    ir_idx = OPND_IDX((*result_opnd));
00914    list_idx1 = IR_IDX_R(ir_idx);
00915    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
00916    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
00917 
00918    conform_check(0, 
00919                  ir_idx,
00920                  res_exp_desc,
00921                  spec_idx,
00922                  FALSE);
00923 
00924    IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx;
00925    IR_RANK(ir_idx) = res_exp_desc->rank;
00926 
00927    switch (ATP_INTRIN_ENUM(*spec_idx)) {
00928       case Sin_Intrinsic:
00929       case Dsin_Intrinsic:
00930       case Qsin_Intrinsic:
00931       case Csin_Intrinsic:
00932       case Cdsin_Intrinsic:
00933       case Cqsin_Intrinsic:
00934 # ifdef KEY
00935       case Zsin_Intrinsic:
00936 # endif
00937          IR_OPR(ir_idx) = Sin_Opr;
00938          break;
00939 
00940       case Sind_Intrinsic:
00941       case Dsind_Intrinsic:
00942       case Qsind_Intrinsic:
00943          IR_OPR(ir_idx) = Sind_Opr;
00944          break;
00945 
00946       case Cos_Intrinsic:
00947       case Dcos_Intrinsic:
00948       case Qcos_Intrinsic:
00949       case Ccos_Intrinsic:
00950       case Cdcos_Intrinsic:
00951       case Cqcos_Intrinsic:
00952 # ifdef KEY
00953       case Zcos_Intrinsic:
00954 # endif
00955          IR_OPR(ir_idx) = Cos_Opr;
00956          break;
00957 
00958       case Cosd_Intrinsic:
00959       case Dcosd_Intrinsic:
00960       case Qcosd_Intrinsic:
00961          IR_OPR(ir_idx) = Cosd_Opr;
00962          break;
00963 
00964       case Log_Intrinsic:
00965       case Alog_Intrinsic:
00966       case Dlog_Intrinsic:
00967       case Qlog_Intrinsic:
00968       case Clog_Intrinsic:
00969       case Cdlog_Intrinsic:
00970       case Cqlog_Intrinsic:
00971 # ifdef KEY
00972       case Zlog_Intrinsic:
00973 # endif
00974          if ((IL_FLD(list_idx1) == CN_Tbl_Idx) &&
00975              (arg_info_list[info_idx1].ed.type == Real)) {
00976 
00977             if (fold_relationals(IL_IDX(list_idx1),
00978                                  CN_INTEGER_ZERO_IDX,
00979                                  Le_Opr)) {
00980 
00981                PRINTMSG(arg_info_list[info_idx1].line, 1062, Error,
00982                         arg_info_list[info_idx1].col);
00983             }
00984          }
00985 
00986          IR_OPR(ir_idx) = Log_E_Opr;
00987          break;
00988 
00989       case Log10_Intrinsic:
00990       case Alog10_Intrinsic:
00991       case Dlog10_Intrinsic:
00992       case Qlog10_Intrinsic:
00993          IR_OPR(ir_idx) = Log_10_Opr;
00994          break;
00995 
00996       case Tan_Intrinsic:
00997       case Dtan_Intrinsic:
00998       case Qtan_Intrinsic:
00999          IR_OPR(ir_idx) = Tan_Opr;
01000          break;
01001 
01002       case Tand_Intrinsic:
01003       case Dtand_Intrinsic:
01004       case Qtand_Intrinsic:
01005          IR_OPR(ir_idx) = Tand_Opr;
01006          break;
01007 
01008       case Tanh_Intrinsic:
01009       case Dtanh_Intrinsic:
01010       case Qtanh_Intrinsic:
01011          IR_OPR(ir_idx) = Tanh_Opr;
01012          break;
01013 
01014       case Sinh_Intrinsic:
01015       case Dsinh_Intrinsic:
01016       case Qsinh_Intrinsic:
01017          IR_OPR(ir_idx) = Sinh_Opr;
01018          break;
01019 
01020       case Cosh_Intrinsic:
01021       case Dcosh_Intrinsic:
01022       case Qcosh_Intrinsic:
01023          IR_OPR(ir_idx) = Cosh_Opr;
01024          break;
01025 
01026       case Acos_Intrinsic:
01027       case Dacos_Intrinsic:
01028       case Qacos_Intrinsic:
01029          IR_OPR(ir_idx) = Acos_Opr;
01030          break;
01031 
01032       case Acosd_Intrinsic:
01033       case Dacosd_Intrinsic:
01034       case Qacosd_Intrinsic:
01035          IR_OPR(ir_idx) = Acosd_Opr;
01036          break;
01037 
01038       case Asin_Intrinsic:
01039       case Dasin_Intrinsic:
01040       case Qasin_Intrinsic:
01041          IR_OPR(ir_idx) = Asin_Opr;
01042          break;
01043 
01044       case Asind_Intrinsic:
01045       case Dasind_Intrinsic:
01046       case Qasind_Intrinsic:
01047          IR_OPR(ir_idx) = Asind_Opr;
01048          break;
01049 
01050       case Atan_Intrinsic:
01051       case Datan_Intrinsic:
01052       case Qatan_Intrinsic:
01053          IR_OPR(ir_idx) = Atan_Opr;
01054          break;
01055 
01056       case Atand_Intrinsic:
01057       case Datand_Intrinsic:
01058       case Qatand_Intrinsic:
01059          IR_OPR(ir_idx) = Atand_Opr;
01060          break;
01061 
01062       case Cot_Intrinsic:
01063       case Dcot_Intrinsic:
01064       case Qcot_Intrinsic:
01065          IR_OPR(ir_idx) = Cot_Opr;
01066          break;
01067 
01068       case Exp_Intrinsic:
01069       case Dexp_Intrinsic:
01070       case Qexp_Intrinsic:
01071       case Cexp_Intrinsic:
01072       case Cdexp_Intrinsic:
01073       case Cqexp_Intrinsic:
01074 # ifdef KEY
01075       case Zexp_Intrinsic:
01076 # endif
01077          IR_OPR(ir_idx) = Exp_Opr;
01078          break;
01079 
01080       case Sqrt_Intrinsic:
01081       case Dsqrt_Intrinsic:
01082       case Qsqrt_Intrinsic:
01083       case Csqrt_Intrinsic:
01084       case Cdsqrt_Intrinsic:
01085       case Cqsqrt_Intrinsic:
01086 # ifdef KEY
01087       case Zsqrt_Intrinsic:
01088 # endif
01089          if ((IL_FLD(list_idx1) == CN_Tbl_Idx) &&
01090              (arg_info_list[info_idx1].ed.type == Real)) {
01091 
01092             if (fold_relationals(IL_IDX(list_idx1),
01093                                  CN_INTEGER_ZERO_IDX,
01094                                  Lt_Opr)) {
01095 
01096                PRINTMSG(arg_info_list[info_idx1].line, 1062, Error,
01097                         arg_info_list[info_idx1].col);
01098             }
01099          }
01100 
01101          IR_OPR(ir_idx) = Sqrt_Opr;
01102          break;
01103 
01104       default:
01105          PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx),
01106                   "sin_intrinsic");
01107          break;
01108    }
01109 
01110    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01111    IR_OPND_R(ir_idx) = null_opnd;
01112 
01113    /* must reset foldable and will_fold_later because there is no */
01114    /* folder for this intrinsic in constructors.                  */
01115 
01116 # if defined(_USE_FOLD_DOT_f)
01117    if (IR_OPR(ir_idx) != Sqrt_Opr) {      
01118 # endif
01119       res_exp_desc->foldable = FALSE;
01120       res_exp_desc->will_fold_later = FALSE;
01121 # if defined(_USE_FOLD_DOT_f)
01122    }
01123 # endif
01124 
01125    /* set this flag so this opr is pulled off io lists */
01126    io_item_must_flatten = TRUE;
01127 
01128    TRACE (Func_Exit, "sin_intrinsic", NULL);
01129 
01130 }  /* sin_intrinsic */
01131 #ifdef KEY /* Bug 1324 */
01132 
01133 /******************************************************************************\
01134 |*                                                                            *|
01135 |* Description:                                                               *|
01136 |*      Function    ERF(X) intrinsic.                                         *|
01137 |*      Function    ERFC(X) intrinsic.                                        *|
01138 |*                                                                            *|
01139 |* Input parameters:                                                          *|
01140 |*      NONE                                                                  *|
01141 |*                                                                            *|
01142 |* Output parameters:                                                         *|
01143 |*      NONE                                                                  *|
01144 |*                                                                            *|
01145 |* Returns:                                                                   *|
01146 |*      NOTHING                                                               *|
01147 |*                                                                            *|
01148 \******************************************************************************/
01149 
01150 void    erf_intrinsic(opnd_type     *result_opnd,
01151                       expr_arg_type *res_exp_desc,
01152                       int           *spec_idx)
01153 {
01154 
01155    int    info_idx1;
01156    int    list_idx1;
01157    int    ir_idx;
01158 
01159 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01160    opnd_type    opnd;
01161 # endif
01162 
01163    TRACE (Func_Entry, "erf_intrinsic", NULL);
01164 
01165    ir_idx = OPND_IDX((*result_opnd));
01166    list_idx1 = IR_IDX_R(ir_idx);
01167    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01168    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
01169 
01170    conform_check(0, 
01171                  ir_idx,
01172                  res_exp_desc,
01173                  spec_idx,
01174                  FALSE);
01175 
01176 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01177 #ifdef KEY /* Bug 4232 */
01178    /* If we're defining a statement function X which calls some
01179     * other function Y, there's no need to generate code to copy
01180     * into temp(s) the actual argument(s) to Y, because we will
01181     * do that when the user program calls the statement function.
01182     * It could be harmful to do that now, since the actual arg to
01183     * Y might be a dummy arg of X, which has no actual address. */
01184    if (!defining_stmt_func) {
01185 #endif /* KEY Bug 4232 */
01186      COPY_OPND(opnd, IR_OPND_R(ir_idx));
01187      final_arg_work(&opnd, IR_IDX_L(ir_idx), IR_LIST_CNT_R(ir_idx), NULL);
01188      COPY_OPND(IR_OPND_R(ir_idx), opnd);
01189 #ifdef KEY /* Bug 4232 */
01190    }
01191 #endif /* KEY Bug 4232 */
01192 # endif
01193 
01194    IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx;
01195    IR_RANK(ir_idx) = res_exp_desc->rank;
01196 
01197    switch (ATP_INTRIN_ENUM(*spec_idx)) {
01198       case Derf_Intrinsic:
01199       case Erf_Intrinsic:
01200          IR_OPR(ir_idx) = Erf_Opr;
01201          break;
01202 
01203       case Derfc_Intrinsic:
01204       case Erfc_Intrinsic:
01205          IR_OPR(ir_idx) = Erfc_Opr;
01206          break;
01207 
01208       default:
01209          PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx),
01210                   "erf_intrinsic");
01211          break;
01212    }
01213 
01214    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01215    IR_OPND_R(ir_idx) = null_opnd;
01216 
01217    /* must reset foldable and will_fold_later because there is no */
01218    /* folder for this intrinsic in constructors.                  */
01219 
01220    res_exp_desc->foldable = FALSE;
01221    res_exp_desc->will_fold_later = FALSE;
01222 
01223    /* set this flag so this opr is pulled off io lists */
01224    io_item_must_flatten = TRUE;
01225 
01226    TRACE (Func_Exit, "erf_intrinsic", NULL);
01227 
01228 }  /* erf_intrinsic */
01229 #endif /* KEY Bug 1324 */
01230 
01231 
01232 /******************************************************************************\
01233 |*                                                                            *|
01234 |* Description:                                                               *|
01235 |*      Function    ABS(A) intrinsic.                                         *|
01236 |*                                                                            *|
01237 |* Input parameters:                                                          *|
01238 |*      NONE                                                                  *|
01239 |*                                                                            *|
01240 |* Output parameters:                                                         *|
01241 |*      NONE                                                                  *|
01242 |*                                                                            *|
01243 |* Returns:                                                                   *|
01244 |*      NOTHING                                                               *|
01245 |*                                                                            *|
01246 \******************************************************************************/
01247 
01248 void    abs_intrinsic(opnd_type     *result_opnd,
01249                       expr_arg_type *res_exp_desc,
01250                       int           *spec_idx)
01251 {
01252    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
01253    int            ir_idx;
01254    int            info_idx1;
01255    int            list_idx1;
01256    int            type_idx;
01257 
01258 
01259    TRACE (Func_Entry, "abs_intrinsic", NULL);
01260 
01261    ir_idx = OPND_IDX((*result_opnd));
01262    list_idx1 = IR_IDX_R(ir_idx);
01263    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01264    type_idx = arg_info_list[info_idx1].ed.type_idx;
01265 
01266    if (TYP_TYPE(type_idx) == Complex) {
01267       switch (TYP_LINEAR(type_idx)) {
01268         case Complex_16:
01269           type_idx = Real_16;
01270           break;
01271 
01272         case Complex_8: 
01273           type_idx = Real_8;
01274           break;
01275 
01276         case Complex_4: 
01277           type_idx = Real_4;
01278           break;
01279       }
01280    }
01281 
01282    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx;
01283 
01284    conform_check(0, 
01285                  ir_idx,
01286                  res_exp_desc,
01287                  spec_idx,
01288                  FALSE);
01289 
01290    IR_TYPE_IDX(ir_idx) = type_idx;
01291    IR_RANK(ir_idx) = res_exp_desc->rank;
01292 
01293    res_exp_desc->type_idx = type_idx;
01294    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
01295    res_exp_desc->type = TYP_TYPE(type_idx);
01296 
01297    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
01298        arg_info_list[info_idx1].ed.type == Integer &&
01299        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
01300                      arg_info_list[info_idx1].ed.type_idx,
01301                      NULL,
01302                      NULL_IDX,
01303                      folded_const,
01304                      &type_idx,
01305                      IR_LINE_NUM(ir_idx),
01306                      IR_COL_NUM(ir_idx),
01307                      1,
01308                      Abs_Opr)) {
01309 
01310       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
01311       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
01312                                                FALSE,
01313                                                folded_const);
01314       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
01315       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
01316       res_exp_desc->constant = TRUE;
01317       res_exp_desc->foldable = TRUE;
01318    }
01319    else {
01320       IR_OPR(ir_idx) = Abs_Opr;
01321       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01322       IR_OPND_R(ir_idx) = null_opnd;
01323 
01324       if (arg_info_list[info_idx1].ed.type != Integer) {
01325          /* must reset foldable and will_fold_later because there is no */
01326          /* folder for this intrinsic in constructors.                  */
01327 
01328          res_exp_desc->foldable = FALSE;
01329          res_exp_desc->will_fold_later = FALSE;
01330       }
01331    }
01332 
01333    TRACE (Func_Exit, "abs_intrinsic", NULL);
01334 
01335 }  /* abs_intrinsic */
01336 
01337 
01338 /******************************************************************************\
01339 |*                                                                            *|
01340 |* Description:                                                               *|
01341 |*      Function    ATAN2(Y, X) intrinsic.                                    *|
01342 |*      Function    ATAN2D(Y, X) intrinsic.                                   *|
01343 |*                                                                            *|
01344 |* Input parameters:                                                          *|
01345 |*      NONE                                                                  *|
01346 |*                                                                            *|
01347 |* Output parameters:                                                         *|
01348 |*      NONE                                                                  *|
01349 |*                                                                            *|
01350 |* Returns:                                                                   *|
01351 |*      NOTHING                                                               *|
01352 |*                                                                            *|
01353 \******************************************************************************/
01354 
01355 void    atan2_intrinsic(opnd_type     *result_opnd,
01356                         expr_arg_type *res_exp_desc,
01357                         int           *spec_idx)
01358 {
01359    int            ir_idx;
01360    int            info_idx1;
01361    int            info_idx2;
01362    int            list_idx1;
01363    int            list_idx2;
01364 
01365 
01366    TRACE (Func_Entry, "atan2_intrinsic", NULL);
01367 
01368    ir_idx = OPND_IDX((*result_opnd));
01369    list_idx1 = IR_IDX_R(ir_idx);
01370    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
01371    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01372    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
01373    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
01374 
01375    conform_check(0, 
01376                  ir_idx,
01377                  res_exp_desc,
01378                  spec_idx,
01379                  FALSE);
01380 
01381    if (arg_info_list[info_idx1].ed.linear_type !=
01382        arg_info_list[info_idx2].ed.linear_type) {
01383       PRINTMSG(arg_info_list[info_idx2].line, 774, Error,
01384                arg_info_list[info_idx2].col);
01385    }     
01386 
01387    IR_TYPE_IDX(ir_idx) = arg_info_list[info_idx1].ed.type_idx;
01388    IR_RANK(ir_idx) = res_exp_desc->rank;
01389 
01390    switch (ATP_INTRIN_ENUM(*spec_idx)) {
01391       case Atan2_Intrinsic:
01392       case Datan2_Intrinsic:
01393       case Qatan2_Intrinsic:
01394          IR_OPR(ir_idx) = Atan2_Opr;
01395          break;
01396 
01397       case Atan2d_Intrinsic:
01398       case Datan2d_Intrinsic:
01399       case Qatan2d_Intrinsic:
01400          IR_OPR(ir_idx) = Atan2d_Opr;
01401          break;
01402 
01403       default:
01404          PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx),
01405                   "atan2_intrinsic");
01406          break;
01407    }
01408 
01409    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01410    IR_OPND_R(ir_idx) = null_opnd;
01411 
01412    /* must reset foldable and will_fold_later because there is no */
01413    /* folder for this intrinsic in constructors.                  */
01414 
01415    res_exp_desc->foldable = FALSE;
01416    res_exp_desc->will_fold_later = FALSE;
01417 
01418    TRACE (Func_Exit, "atan2_intrinsic", NULL);
01419 
01420 }  /* atan2_intrinsic */
01421 
01422 
01423 /******************************************************************************\
01424 |*                                                                            *|
01425 |* Description:                                                               *|
01426 |*      Function    AIMAG(Z) intrinsic.                                       *|
01427 |*                                                                            *|
01428 |* Input parameters:                                                          *|
01429 |*      NONE                                                                  *|
01430 |*                                                                            *|
01431 |* Output parameters:                                                         *|
01432 |*      NONE                                                                  *|
01433 |*                                                                            *|
01434 |* Returns:                                                                   *|
01435 |*      NOTHING                                                               *|
01436 |*                                                                            *|
01437 \******************************************************************************/
01438 
01439 void    aimag_intrinsic(opnd_type     *result_opnd,
01440                         expr_arg_type *res_exp_desc,
01441                         int           *spec_idx)
01442 {
01443    int            ir_idx;
01444 #ifdef KEY /* Bug 10177 */
01445    int            type_idx = 0;
01446 #else /* KEY Bug 10177 */
01447    int            type_idx;
01448 #endif /* KEY Bug 10177 */
01449    int            info_idx1;
01450    int            list_idx1;
01451 
01452 
01453    TRACE (Func_Entry, "aimag_intrinsic", NULL);
01454 
01455    ir_idx = OPND_IDX((*result_opnd));
01456    list_idx1 = IR_IDX_R(ir_idx);
01457    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01458 
01459    switch (arg_info_list[info_idx1].ed.linear_type) {
01460      case Complex_4:   type_idx = Real_4;   break;
01461      case Complex_8:   type_idx = Real_8;   break;
01462      case Complex_16:  type_idx = Real_16;  break;
01463    }
01464 
01465    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = type_idx;
01466 
01467    conform_check(0, 
01468                  ir_idx,
01469                  res_exp_desc,
01470                  spec_idx,
01471                  FALSE);
01472 
01473    IR_TYPE_IDX(ir_idx) = type_idx;
01474    IR_RANK(ir_idx) = res_exp_desc->rank;
01475 
01476    IR_OPR(ir_idx) = Aimag_Opr;
01477    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01478    IR_OPND_R(ir_idx) = null_opnd;
01479 
01480    /* must reset foldable and will_fold_later because there is no */
01481    /* folder for this intrinsic in constructors.                  */
01482 
01483    res_exp_desc->foldable = FALSE;
01484    res_exp_desc->will_fold_later = FALSE;
01485 
01486    TRACE (Func_Exit, "aimag_intrinsic", NULL);
01487 
01488 }  /* aimag_intrinsic */
01489 
01490 
01491 
01492 /******************************************************************************\
01493 |*                                                                            *|
01494 |* Description:                                                               *|
01495 |*      Function    SHORT(A) intrinsic.                             *|
01496 |*      Function    LONG(A) intrinsic.                              *|
01497 |*      Function    IDINT(A) intrinsic.                                       *|
01498 |*      Function    IIDINT(A) intrinsic.                                      *|
01499 |*      Function    JIDINT(A) intrinsic.                                      *|
01500 |*      Function    KIDINT(A) intrinsic.                                      *|
01501 |*      Function    IQINT(A) intrinsic.                                       *|
01502 |*      Function    IIQINT(A) intrinsic.                                      *|
01503 |*      Function    JIQINT(A) intrinsic.                                      *|
01504 |*      Function    KIQINT(A) intrinsic.                                      *|
01505 |*      Function    INT(A, KIND) intrinsic.                                   *|
01506 |*      Function    INT1(A) intrinsic.                                        *|
01507 |*      Function    INT2(A) intrinsic.                                        *|
01508 |*      Function    INT4(A) intrinsic.                                        *|
01509 |*      Function    INT8(A) intrinsic.                                        *|
01510 |*      Function    IINT(A) intrinsic.                                        *|
01511 |*      Function    JINT(A) intrinsic.                                        *|
01512 |*      Function    KINT(A) intrinsic.                                        *|
01513 |*      Function    IFIX(A) intrinsic.                                        *|
01514 |*      Function    IIFIX(A) intrinsic.                                       *|
01515 |*      Function    JIFIX(A) intrinsic.                                       *|
01516 |*      Function    KIFIX(A) intrinsic.                                       *|
01517 |*                                                                            *|
01518 |* Input parameters:                                                          *|
01519 |*      NONE                                                                  *|
01520 |*                                                                            *|
01521 |* Output parameters:                                                         *|
01522 |*      NONE                                                                  *|
01523 |*                                                                            *|
01524 |* Returns:                                                                   *|
01525 |*      NOTHING                                                               *|
01526 |*                                                                            *|
01527 \******************************************************************************/
01528 
01529 void   int_intrinsic(opnd_type     *result_opnd,
01530                      expr_arg_type *res_exp_desc,
01531                      int           *spec_idx)
01532 {
01533    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
01534    int            ir_idx;
01535    int            list_idx1;
01536    int            list_idx2;
01537    int            info_idx1;
01538    int            info_idx2;
01539    opnd_type    opnd;
01540    int      type_idx;
01541 
01542 
01543    TRACE (Func_Entry, "int_intrinsic", NULL);
01544 
01545    ir_idx = OPND_IDX((*result_opnd));
01546    list_idx1 = IR_IDX_R(ir_idx);
01547    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
01548    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01549 
01550    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
01551       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
01552       kind_to_linear_type(&((IL_OPND(list_idx2))), 
01553                           ATP_RSLT_IDX(*spec_idx),
01554                           arg_info_list[info_idx2].ed.kind0seen,
01555                           arg_info_list[info_idx2].ed.kind0E0seen,
01556                           arg_info_list[info_idx2].ed.kind0D0seen,
01557                           ! arg_info_list[info_idx2].ed.kindnotconst);
01558    }
01559    else {
01560       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
01561    }
01562 
01563    if (ATP_INTRIN_ENUM(*spec_idx) == Int1_Intrinsic) {
01564       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_1;
01565    }
01566    else if (ATP_INTRIN_ENUM(*spec_idx) == Short_Intrinsic ||
01567        ATP_INTRIN_ENUM(*spec_idx) == Int2_Intrinsic ||
01568        ATP_INTRIN_ENUM(*spec_idx) == Iint_Intrinsic ||
01569        ATP_INTRIN_ENUM(*spec_idx) == Iifix_Intrinsic ||
01570        ATP_INTRIN_ENUM(*spec_idx) == Iidint_Intrinsic ||
01571        ATP_INTRIN_ENUM(*spec_idx) == Iiqint_Intrinsic) {
01572       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_2;
01573    }
01574    else if (ATP_INTRIN_ENUM(*spec_idx) == Long_Intrinsic ||
01575             ATP_INTRIN_ENUM(*spec_idx) == Int4_Intrinsic ||
01576             ATP_INTRIN_ENUM(*spec_idx) == Jint_Intrinsic ||
01577             ATP_INTRIN_ENUM(*spec_idx) == Jifix_Intrinsic ||
01578             ATP_INTRIN_ENUM(*spec_idx) == Jidint_Intrinsic ||
01579             ATP_INTRIN_ENUM(*spec_idx) == Jiqint_Intrinsic) {
01580       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_4;
01581    }
01582    else if (ATP_INTRIN_ENUM(*spec_idx) == Kint_Intrinsic ||
01583             ATP_INTRIN_ENUM(*spec_idx) == Int8_Intrinsic ||
01584             ATP_INTRIN_ENUM(*spec_idx) == Kifix_Intrinsic ||
01585             ATP_INTRIN_ENUM(*spec_idx) == Kidint_Intrinsic ||
01586             ATP_INTRIN_ENUM(*spec_idx) == Kiqint_Intrinsic) {
01587       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
01588    }
01589 
01590    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
01591 
01592    conform_check(0, 
01593                  ir_idx,
01594                  res_exp_desc,
01595                  spec_idx,
01596                  FALSE);
01597 
01598    if (arg_info_list[info_idx1].ed.type == Real) {
01599       COPY_OPND(opnd, IL_OPND(list_idx1));
01600       look_for_real_div(&opnd);
01601       COPY_OPND(IL_OPND(list_idx1), opnd);
01602    }
01603 
01604    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
01605    IR_RANK(ir_idx) = res_exp_desc->rank;
01606    res_exp_desc->type_idx = type_idx;
01607    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
01608 
01609 #ifdef KEY /* Bug 12482 */
01610    if (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const) {
01611       typeless_to_type(list_idx1, type_idx);
01612       COPY_OPND(*result_opnd, IL_OPND(list_idx1));
01613       res_exp_desc->constant = TRUE;
01614       res_exp_desc->foldable = TRUE;
01615    }
01616    else
01617 #endif /* KEY Bug 12482 */
01618 
01619    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
01620        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
01621                         arg_info_list[info_idx1].ed.type_idx,
01622                         NULL,
01623                         NULL_IDX,
01624                         folded_const,
01625                         &type_idx,
01626                         IR_LINE_NUM(ir_idx),
01627                         IR_COL_NUM(ir_idx),
01628                         1,
01629                         Int_Opr)) {
01630 
01631       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
01632       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
01633                                                FALSE,
01634                                                folded_const);
01635       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
01636       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
01637       res_exp_desc->constant = TRUE;
01638       res_exp_desc->foldable = TRUE;
01639    }
01640    else {       
01641       IR_OPR(ir_idx) = Int_Opr;
01642       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
01643       IR_OPND_R(ir_idx) = null_opnd;
01644       IR_LIST_CNT_L(ir_idx) = 1;
01645       IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX;
01646    }
01647 
01648    TRACE (Func_Exit, "int_intrinsic", NULL);
01649 
01650 }  /* int_intrinsic */
01651 
01652 
01653 /******************************************************************************\
01654 |*                                                                            *|
01655 |* Description:                                                               *|
01656 |*      Function    IAND(I, J) intrinsic.                                     *|
01657 |*      Function    IIAND(I, J) intrinsic.                                    *|
01658 |*      Function    JIAND(I, J) intrinsic.                                    *|
01659 |*      Function    KIAND(I, J) intrinsic.                                    *|
01660 |*      Function    AND(I, J) intrinsic.                                      *|
01661 |*      Function    IEOR(I, J) intrinsic.                                     *|
01662 |*      Function    IIEOR(I, J) intrinsic.                                    *|
01663 |*      Function    JIEOR(I, J) intrinsic.                                    *|
01664 |*      Function    KIEOR(I, J) intrinsic.                                    *|
01665 |*      Function    NEQV(I, J) intrinsic.                                     *|
01666 |*      Function    XOR(I, J) intrinsic.                                      *|
01667 |*      Function    IOR(I, J) intrinsic.                                      *|
01668 |*      Function    IIOR(I, J) intrinsic.                                     *|
01669 |*      Function    JIOR(I, J) intrinsic.                                     *|
01670 |*      Function    KIOR(I, J) intrinsic.                                     *|
01671 |*      Function    OR(I, J) intrinsic.                                       *|
01672 |*      Function    EQV(I, J) intrinsic.                                      *|
01673 |*                                                                            *|
01674 |* Input parameters:                                                          *|
01675 |*      NONE                                                                  *|
01676 |*                                                                            *|
01677 |* Output parameters:                                                         *|
01678 |*      NONE                                                                  *|
01679 |*                                                                            *|
01680 |* Returns:                                                                   *|
01681 |*      NOTHING                                                               *|
01682 |*                                                                            *|
01683 \******************************************************************************/
01684 
01685 void    iand_intrinsic(opnd_type     *result_opnd,
01686                        expr_arg_type *res_exp_desc,
01687                        int           *spec_idx)
01688 {
01689    opnd_type      opnd;
01690    int            cn_idx;
01691    int            cn_idx2;
01692    int            typeless_idx;
01693    int            minus_idx;
01694    int            column;
01695    int            info_idx1;
01696    int            info_idx2;
01697    int            line;
01698    int            list_idx1;
01699    int            list_idx2;
01700    long     num;
01701    int            shiftl_idx;
01702    int            shiftr_idx;
01703    int            first_idx;
01704    int            second_idx;
01705    int            not_idx;
01706    int            ir_idx;
01707    boolean        ok = TRUE;
01708 #ifdef KEY /* Bug 10177 */
01709    operator_type  opr = Null_Opr;
01710 #else /* KEY Bug 10177 */
01711    operator_type  opr;
01712 #endif /* KEY Bug 10177 */
01713    int            type_idx;
01714 
01715 
01716    TRACE (Func_Entry, "iand_intrinsic", NULL);
01717 
01718    ir_idx = OPND_IDX((*result_opnd));
01719 
01720    list_idx1 = IR_IDX_R(ir_idx);
01721    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
01722    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
01723    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
01724 
01725    if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
01726        (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const ||
01727         arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) {
01728 
01729       find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1),
01730                                 &line,
01731                                 &column);
01732 
01733       if (arg_info_list[info_idx1].ed.type == Character) {
01734          PRINTMSG(line, 161, Ansi, column);
01735       }
01736 
01737       type_idx = arg_info_list[info_idx2].ed.type_idx;
01738 
01739       if (arg_info_list[info_idx2].ed.type == Character ||
01740           arg_info_list[info_idx2].ed.type == Typeless) {
01741          type_idx = INTEGER_DEFAULT_TYPE;
01742       }
01743 
01744       IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1),
01745                                                  type_idx,
01746                                                  line,
01747                                                  column);
01748 
01749       arg_info_list[info_idx1].ed.type_idx = type_idx;
01750       arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx);
01751       arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx);
01752    }
01753 
01754    if (IL_FLD(list_idx2) == CN_Tbl_Idx &&
01755        (arg_info_list[info_idx2].ed.linear_type == Short_Typeless_Const ||
01756         arg_info_list[info_idx2].ed.linear_type == Short_Char_Const)) {
01757 
01758       find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx2),
01759                                 &line,
01760                                 &column);
01761 
01762       if (arg_info_list[info_idx2].ed.type == Character) {
01763          PRINTMSG(line, 161, Ansi, column);
01764       }
01765 
01766       type_idx = arg_info_list[info_idx1].ed.type_idx;
01767 
01768       if (arg_info_list[info_idx1].ed.type == Character ||
01769           arg_info_list[info_idx1].ed.type == Typeless) {
01770          type_idx = INTEGER_DEFAULT_TYPE;
01771       }
01772 
01773       IL_IDX(list_idx2) = cast_typeless_constant(IL_IDX(list_idx2),
01774                                                  type_idx,
01775                                                  line,
01776                                                  column);
01777 
01778       arg_info_list[info_idx2].ed.type_idx = type_idx;
01779       arg_info_list[info_idx2].ed.type = TYP_TYPE(type_idx);
01780       arg_info_list[info_idx2].ed.linear_type = TYP_LINEAR(type_idx);
01781    }
01782 
01783 
01784    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
01785 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01786    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
01787    if (arg_info_list[info_idx1].ed.type == Integer) {
01788       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
01789       arg_info_list[info_idx1].ed.linear_type;
01790    }
01791 # endif
01792 
01793 # ifdef _TARGET32
01794    if (arg_info_list[info_idx1].ed.linear_type == Integer_8 ||
01795        arg_info_list[info_idx1].ed.linear_type == Typeless_8 ||
01796        arg_info_list[info_idx1].ed.linear_type == Real_8) {
01797       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8;
01798 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01799       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
01800 # endif
01801    }
01802 # endif
01803 
01804 # ifdef _TARGET_OS_MAX
01805    if (arg_info_list[info_idx1].ed.linear_type == Integer_1 ||
01806        arg_info_list[info_idx1].ed.linear_type == Integer_2 ||
01807        arg_info_list[info_idx1].ed.linear_type == Integer_4 ||
01808        arg_info_list[info_idx1].ed.linear_type == Typeless_4 ||
01809        arg_info_list[info_idx1].ed.linear_type == Real_4) {
01810        ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4;
01811    }
01812 # endif
01813 
01814 
01815    if (ATP_INTRIN_ENUM(*spec_idx) == Iand_Intrinsic ||
01816        ATP_INTRIN_ENUM(*spec_idx) == Iiand_Intrinsic ||
01817        ATP_INTRIN_ENUM(*spec_idx) == Jiand_Intrinsic ||
01818        ATP_INTRIN_ENUM(*spec_idx) == Kiand_Intrinsic ||
01819        ATP_INTRIN_ENUM(*spec_idx) == Ior_Intrinsic ||
01820        ATP_INTRIN_ENUM(*spec_idx) == Iior_Intrinsic ||
01821        ATP_INTRIN_ENUM(*spec_idx) == Jior_Intrinsic ||
01822        ATP_INTRIN_ENUM(*spec_idx) == Kior_Intrinsic ||
01823        ATP_INTRIN_ENUM(*spec_idx) == Ieor_Intrinsic ||
01824        ATP_INTRIN_ENUM(*spec_idx) == Iieor_Intrinsic ||
01825        ATP_INTRIN_ENUM(*spec_idx) == Jieor_Intrinsic ||
01826        ATP_INTRIN_ENUM(*spec_idx) == Kieor_Intrinsic) {
01827       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
01828       arg_info_list[info_idx1].ed.type_idx;
01829 
01830       if (arg_info_list[info_idx1].ed.type == Typeless ||
01831           arg_info_list[info_idx2].ed.type == Typeless) {
01832          PRINTMSG(arg_info_list[info_idx1].line, 1076, Ansi,
01833                   arg_info_list[info_idx1].col);
01834 
01835          ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
01836       }
01837 
01838 # ifdef _TARGET32
01839       if (arg_info_list[info_idx1].ed.linear_type == Integer_8 ||
01840           arg_info_list[info_idx1].ed.linear_type == Typeless_8) {
01841          ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
01842       }
01843 # endif
01844 
01845       if (arg_info_list[info_idx1].ed.linear_type !=
01846           arg_info_list[info_idx2].ed.linear_type) {
01847          PRINTMSG(arg_info_list[info_idx2].line, 774, Error,
01848                   arg_info_list[info_idx2].col);
01849          ok = FALSE;
01850       }
01851    }
01852 
01853 
01854 
01855    switch (ATP_INTRIN_ENUM(*spec_idx)) {
01856       case Iand_Intrinsic:
01857       case Iiand_Intrinsic:
01858       case Jiand_Intrinsic:
01859       case Kiand_Intrinsic:
01860            opr = Band_Opr;
01861            break;
01862 
01863       case Ior_Intrinsic:
01864       case Iior_Intrinsic:
01865       case Jior_Intrinsic:
01866       case Kior_Intrinsic:
01867            opr = Bor_Opr;
01868            break;
01869 
01870       case Ieor_Intrinsic:
01871       case Iieor_Intrinsic:
01872       case Jieor_Intrinsic:
01873       case Kieor_Intrinsic:
01874            opr = Bneqv_Opr;
01875            break;
01876 
01877       case And_Intrinsic:
01878            opr = Band_Opr;
01879            if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] !=
01880                storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) {
01881               PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error,
01882                        IR_COL_NUM(ir_idx));
01883               ok = FALSE;
01884            }
01885            else if (arg_info_list[info_idx1].ed.type == Logical &&
01886                     arg_info_list[info_idx2].ed.type == Logical) {
01887               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
01888               opr = And_Opr;
01889 
01890            }
01891            break;
01892 
01893       case Or_Intrinsic:
01894            opr = Bor_Opr;
01895            if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] !=
01896                storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) {
01897               PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error,
01898                        IR_COL_NUM(ir_idx));
01899               ok = FALSE;
01900            }
01901            else if (arg_info_list[info_idx1].ed.type == Logical &&
01902                     arg_info_list[info_idx2].ed.type == Logical) {
01903               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
01904               opr = Or_Opr;
01905            }
01906            break;
01907 
01908       case Xor_Intrinsic:
01909            opr = Bneqv_Opr;
01910            if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] !=
01911                storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) {
01912               PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error,
01913                        IR_COL_NUM(ir_idx));
01914               ok = FALSE;
01915            }
01916 #ifdef KEY /* Bug 1683 */
01917 #else
01918      /* g77 compatibility requires an "xor" which operates bitwise
01919       * regardless of data type. Seems stupid for Xor_Intrinsic and
01920       * Neqv_Intrinsic to do the same thing, so make Xor_Intrinsic
01921       * operate bitwise, and then the table in intrin.h can map
01922       * each user-visible intrinsic name onto whichever operation
01923       * we desire.  */
01924            else if (arg_info_list[info_idx1].ed.type == Logical &&
01925                     arg_info_list[info_idx2].ed.type == Logical) {
01926               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
01927               opr = Neqv_Opr;
01928            }
01929 #endif /* KEY Bug 1683 */
01930            break;
01931 
01932       case Neqv_Intrinsic:
01933            opr = Bneqv_Opr;
01934            if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] !=
01935                storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) {
01936               PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error,
01937                        IR_COL_NUM(ir_idx));
01938               ok = FALSE;
01939            }
01940            else if (arg_info_list[info_idx1].ed.type == Logical &&
01941                     arg_info_list[info_idx2].ed.type == Logical) {
01942               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
01943               opr = Neqv_Opr;
01944            }
01945            break;
01946 
01947       case Eqv_Intrinsic:
01948            opr = Beqv_Opr;
01949            if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] !=
01950                storage_bit_size_tbl[arg_info_list[info_idx2].ed.linear_type]) {
01951               PRINTMSG(IR_LINE_NUM(ir_idx), 1188, Error,
01952                        IR_COL_NUM(ir_idx));
01953               ok = FALSE;
01954            }
01955            else if (arg_info_list[info_idx1].ed.type == Logical &&
01956                     arg_info_list[info_idx2].ed.type == Logical) {
01957               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
01958               opr = Eqv_Opr;
01959            }
01960            break;
01961 
01962       default:
01963          PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal, IR_COL_NUM(ir_idx),
01964                   "iand_intrinsic");
01965          break;
01966    }
01967 
01968    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
01969 
01970    if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8 ||
01971        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_8) {
01972       typeless_idx = Typeless_8;
01973 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01974       typeless_idx = Integer_8;
01975 # endif
01976    }
01977    else {
01978       typeless_idx = TYPELESS_DEFAULT_TYPE;
01979 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
01980       typeless_idx = INTEGER_DEFAULT_TYPE;
01981       if (arg_info_list[info_idx1].ed.type == Integer) {
01982          typeless_idx = arg_info_list[info_idx1].ed.linear_type;
01983       }
01984 # endif
01985    }
01986 
01987 # ifdef _TARGET_OS_MAX
01988    if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 ||
01989        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 ||
01990        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_4 ||
01991        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) {
01992       typeless_idx = Typeless_4;
01993    }
01994 # endif
01995    
01996    conform_check(0, 
01997                  ir_idx,
01998                  res_exp_desc,
01999                  spec_idx,
02000                  FALSE);
02001 
02002    IR_TYPE_IDX(ir_idx) = type_idx;
02003    IR_RANK(ir_idx) = res_exp_desc->rank;
02004    res_exp_desc->type_idx = type_idx;
02005    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
02006 
02007    if (opr == And_Opr ||
02008        opr == Or_Opr ||
02009        opr == Eqv_Opr ||
02010        opr == Neqv_Opr) {
02011       IR_OPR(ir_idx) = opr;
02012       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02013       IR_OPND_R(ir_idx) = null_opnd;
02014    }
02015    else {
02016 
02017 
02018    line = IR_LINE_NUM(ir_idx);
02019    column = IR_COL_NUM(ir_idx);
02020 
02021    not_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1),
02022                  opr, typeless_idx, line, column,
02023                     IL_FLD(list_idx2), IL_IDX(list_idx2));
02024 
02025    num=storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))];
02026 
02027    cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num);
02028 
02029    switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) {
02030          case Integer_1:
02031               num = BITSIZE_INT1_F90;
02032               break;
02033 
02034          case Integer_2:
02035               num = BITSIZE_INT2_F90;
02036               break;
02037 
02038          case Integer_4:
02039          case Typeless_4:
02040               num = BITSIZE_INT4_F90;
02041               break;
02042 
02043          case Integer_8:
02044          case Typeless_8:
02045               num = BITSIZE_INT8_F90;
02046               break;
02047    }
02048 
02049    cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num);
02050 
02051    minus_idx = gen_ir(CN_Tbl_Idx, cn_idx,
02052                  Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column,
02053                       CN_Tbl_Idx, cn_idx2);
02054 
02055 
02056    NTR_IR_LIST_TBL(first_idx);
02057    IL_FLD(first_idx) = IR_Tbl_Idx;
02058    IL_IDX(first_idx) = not_idx;
02059    NTR_IR_LIST_TBL(second_idx);
02060    IL_FLD(second_idx) = IR_Tbl_Idx;
02061    IL_IDX(second_idx) = minus_idx;
02062    IL_NEXT_LIST_IDX(first_idx) = second_idx;
02063 
02064    shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx,
02065                   Shiftl_Opr, typeless_idx, line, column,
02066                        NO_Tbl_Idx, NULL_IDX);
02067 
02068    NTR_IR_LIST_TBL(first_idx);
02069    IL_FLD(first_idx) = IR_Tbl_Idx;
02070    IL_IDX(first_idx) = shiftl_idx;
02071    NTR_IR_LIST_TBL(second_idx);
02072    IL_FLD(second_idx) = IR_Tbl_Idx;
02073    IL_IDX(second_idx) = minus_idx;
02074    IL_NEXT_LIST_IDX(first_idx) = second_idx;
02075 
02076    shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx,
02077                   Shiftr_Opr, typeless_idx, line, column,
02078                        NO_Tbl_Idx, NULL_IDX);
02079 
02080    if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer) {
02081       IR_OPR(shiftr_idx) = Shifta_Opr;
02082    }
02083 
02084    IR_OPR(ir_idx) = Cvrt_Opr;
02085    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02086    IR_FLD_L(ir_idx) = IR_Tbl_Idx;
02087    IR_IDX_L(ir_idx) = shiftr_idx;
02088    IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
02089    IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
02090    IR_FLD_R(ir_idx) = NO_Tbl_Idx;
02091    IR_IDX_R(ir_idx) = NULL_IDX;
02092 
02093    if (ok &&
02094        IL_FLD(list_idx1) == CN_Tbl_Idx &&
02095        IL_FLD(list_idx2) == CN_Tbl_Idx) {
02096       COPY_OPND(opnd, (*result_opnd));
02097       ok = fold_aggragate_expression(&opnd, res_exp_desc, FALSE);
02098       COPY_OPND((*result_opnd), opnd);
02099    }
02100 
02101    }
02102 
02103    TRACE (Func_Exit, "iand_intrinsic", NULL);
02104 
02105 }  /* iand_intrinsic */
02106 
02107 
02108 /******************************************************************************\
02109 |*                                                                            *|
02110 |* Description:                                                               *|
02111 |*      Function    MOD(A, P) intrinsic.                                      *|
02112 |*                                                                            *|
02113 |* Input parameters:                                                          *|
02114 |*      NONE                                                                  *|
02115 |*                                                                            *|
02116 |* Output parameters:                                                         *|
02117 |*      NONE                                                                  *|
02118 |*                                                                            *|
02119 |* Returns:                                                                   *|
02120 |*      NOTHING                                                               *|
02121 |*                                                                            *|
02122 \******************************************************************************/
02123 
02124 void    mod_intrinsic(opnd_type     *result_opnd,
02125                       expr_arg_type *res_exp_desc,
02126                       int           *spec_idx)
02127 {
02128    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
02129    int            info_idx1;
02130    int            info_idx2;
02131    int            list_idx1;
02132    int            list_idx2;
02133    int            ir_idx;
02134    int            type_idx;
02135 
02136 
02137    TRACE (Func_Entry, "mod_intrinsic", NULL);
02138 
02139    ir_idx = OPND_IDX((*result_opnd));
02140 
02141    list_idx1 = IR_IDX_R(ir_idx);
02142    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02143    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02144    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02145 
02146    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
02147    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02148 
02149    conform_check(0, 
02150                  ir_idx,
02151                  res_exp_desc,
02152                  spec_idx,
02153                  FALSE);
02154 
02155    IR_TYPE_IDX(ir_idx) = type_idx;
02156    IR_RANK(ir_idx) = res_exp_desc->rank;
02157    res_exp_desc->type_idx = type_idx;
02158    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
02159 
02160    if (arg_info_list[info_idx1].ed.linear_type != 
02161        arg_info_list[info_idx2].ed.linear_type) {
02162       PRINTMSG(IR_LINE_NUM(ir_idx), 774,  Error, 
02163                IR_COL_NUM(ir_idx));
02164    }
02165 
02166    if (arg_info_list[info_idx1].ed.type == Integer &&
02167        IL_FLD(list_idx1) == CN_Tbl_Idx &&
02168        IL_FLD(list_idx2) == CN_Tbl_Idx &&
02169        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
02170                      arg_info_list[info_idx1].ed.type_idx,
02171                      (char *)&CN_CONST(IL_IDX(list_idx2)),
02172                      arg_info_list[info_idx2].ed.type_idx,
02173                      folded_const,
02174                      &type_idx,
02175                      IR_LINE_NUM(ir_idx),
02176                      IR_COL_NUM(ir_idx),
02177                      2,
02178                      Mod_Opr)) {
02179       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
02180       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
02181                                                FALSE,
02182                                                folded_const);
02183       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
02184       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
02185       res_exp_desc->constant = TRUE;
02186       res_exp_desc->foldable = TRUE;
02187    }
02188    else {
02189       IR_OPR(ir_idx) = Mod_Opr;
02190       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02191       IR_OPND_R(ir_idx) = null_opnd;
02192 
02193       if (arg_info_list[info_idx1].ed.type != Integer) {
02194          /* must reset foldable and will_fold_later because there is no */
02195          /* folder for this intrinsic in constructors.                  */
02196 
02197          res_exp_desc->foldable = FALSE;
02198          res_exp_desc->will_fold_later = FALSE;
02199       }
02200    } 
02201 
02202    TRACE (Func_Exit, "mod_intrinsic", NULL);
02203 
02204 }  /* mod_intrinsic */
02205 
02206 
02207 /******************************************************************************\
02208 |*                                                                            *|
02209 |* Description:                                                               *|
02210 |*      Subroutine  FREE(P) intrinsic.                                    *|
02211 |*      Subroutine  TIME(BUF) intrinsic.                                    *|
02212 |*                                                                            *|
02213 |* Input parameters:                                                          *|
02214 |*      NONE                                                                  *|
02215 |*                                                                            *|
02216 |* Output parameters:                                                         *|
02217 |*      NONE                                                                  *|
02218 |*                                                                            *|
02219 |* Returns:                                                                   *|
02220 |*      NOTHING                                                               *|
02221 |*                                                                            *|
02222 \******************************************************************************/
02223 void    free_intrinsic(opnd_type     *result_opnd,
02224                        expr_arg_type *res_exp_desc,
02225                        int           *spec_idx)
02226 {
02227    int            ir_idx;
02228 
02229 
02230    TRACE (Func_Entry, "free_intrinsic", NULL);
02231 
02232    ir_idx = OPND_IDX((*result_opnd));
02233 
02234    conform_check(0, 
02235                  ir_idx,
02236                  res_exp_desc,
02237                  spec_idx,
02238                  FALSE);
02239 
02240    IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
02241    IR_RANK(ir_idx) = res_exp_desc->rank;
02242 
02243    if (!ATP_EXTERNAL_INTRIN(*spec_idx)) {
02244       IR_OPR(ir_idx) = Free_Opr;
02245       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02246       IR_OPND_R(ir_idx) = null_opnd;
02247    }
02248 
02249    /* must reset foldable and will_fold_later because there is no */
02250    /* folder for this intrinsic in constructors.                  */
02251 
02252    res_exp_desc->foldable = FALSE;
02253    res_exp_desc->will_fold_later = FALSE;
02254 
02255    TRACE (Func_Exit, "free_intrinsic", NULL);
02256 
02257 }  /* free_intrinsic */
02258 
02259 
02260 /******************************************************************************\
02261 |*                                                                            *|
02262 |* Description:                                                               *|
02263 |*      Function    MALLOC(P) intrinsic.                                      *|
02264 |*                                                                            *|
02265 |* Input parameters:                                                          *|
02266 |*      NONE                                                                  *|
02267 |*                                                                            *|
02268 |* Output parameters:                                                         *|
02269 |*      NONE                                                                  *|
02270 |*                                                                            *|
02271 |* Returns:                                                                   *|
02272 |*      NOTHING                                                               *|
02273 |*                                                                            *|
02274 \******************************************************************************/
02275 void    malloc_intrinsic(opnd_type     *result_opnd,
02276                          expr_arg_type *res_exp_desc,
02277                          int           *spec_idx)
02278 {
02279    int            ir_idx;
02280 
02281 
02282    TRACE (Func_Entry, "malloc_intrinsic", NULL);
02283 
02284    ir_idx = OPND_IDX((*result_opnd));
02285 
02286    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ptr_8;
02287 
02288    conform_check(0, 
02289                  ir_idx,
02290                  res_exp_desc,
02291                  spec_idx,
02292                  FALSE);
02293 
02294    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02295    IR_RANK(ir_idx) = res_exp_desc->rank;
02296    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02297    res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
02298 
02299    if (!ATP_EXTERNAL_INTRIN(*spec_idx)) {
02300       IR_OPR(ir_idx) = Malloc_Opr;
02301       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02302       IR_OPND_R(ir_idx) = null_opnd;
02303    }
02304 
02305    /* must reset foldable and will_fold_later because there is no */
02306    /* folder for this intrinsic in constructors.                  */
02307 
02308    res_exp_desc->foldable = FALSE;
02309    res_exp_desc->will_fold_later = FALSE;
02310 
02311    TRACE (Func_Exit, "malloc_intrinsic", NULL);
02312 
02313 }  /* malloc_intrinsic */
02314 
02315 
02316 
02317 /******************************************************************************\
02318 |*                                                                            *|
02319 |* Description:                                                               *|
02320 |*      Function    NULL(MOLD) intrinsic.                                     *|
02321 |*                                                                            *|
02322 |* Input parameters:                                                          *|
02323 |*      NONE                                                                  *|
02324 |*                                                                            *|
02325 |* Output parameters:                                                         *|
02326 |*      NONE                                                                  *|
02327 |*                                                                            *|
02328 |* Returns:                                                                   *|
02329 |*      NOTHING                                                               *|
02330 |*                                                                            *|
02331 \******************************************************************************/
02332 void    null_intrinsic(opnd_type     *result_opnd,
02333                        expr_arg_type *res_exp_desc,
02334                        int           *spec_idx)
02335 {
02336    int            info_idx1;
02337    int            ir_idx;
02338    int            line;
02339    int            col;
02340    int            list_idx1;
02341    int            tmp_dv_idx;
02342    int            attr_idx;
02343    opnd_type      dv_opnd;
02344 
02345 
02346    TRACE (Func_Entry, "null_intrinsic", NULL);
02347 
02348    ir_idx = OPND_IDX((*result_opnd));
02349    list_idx1 = IR_IDX_R(ir_idx);
02350 
02351    line = IR_LINE_NUM(ir_idx);
02352    col = IR_COL_NUM(ir_idx);
02353 
02354    conform_check(0,
02355                  ir_idx,
02356                  res_exp_desc,
02357                  spec_idx,
02358                  FALSE);
02359 
02360    if (list_idx1 == NULL_IDX || IL_IDX(list_idx1) == NULL_IDX) {
02361       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
02362       ATD_POINTER(ATP_RSLT_IDX(*spec_idx)) = TRUE;
02363       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02364       IR_RANK(ir_idx) = res_exp_desc->rank;
02365       res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02366       res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
02367       res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
02368       res_exp_desc->pointer = TRUE;
02369 
02370       IR_OPR(ir_idx) = Null_Intrinsic_Opr;
02371       IR_OPND_R(ir_idx) = null_opnd;
02372       IR_LINE_NUM_R(ir_idx) = IR_LINE_NUM(ir_idx);
02373       IR_COL_NUM_R(ir_idx) = IR_COL_NUM(ir_idx);
02374       IR_OPND_R(ir_idx) = null_opnd;
02375       IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
02376       IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
02377 
02378       res_exp_desc->foldable = FALSE;
02379       res_exp_desc->will_fold_later = FALSE;
02380    } 
02381    else {
02382       info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02383 
02384       if (TYP_TYPE(arg_info_list[info_idx1].ed.type_idx) == Character) {
02385          COPY_OPND((res_exp_desc->char_len),
02386                    (arg_info_list[info_idx1].ed.char_len));
02387       }
02388 
02389       attr_idx = find_base_attr(&IL_OPND(list_idx1), &line, &col);
02390 
02391       if (IL_FLD(list_idx1) == CN_Tbl_Idx || !ATD_POINTER(attr_idx)) {
02392          PRINTMSG(arg_info_list[info_idx1].line, 1574, Error,
02393                   arg_info_list[info_idx1].col);
02394          res_exp_desc->foldable = FALSE;
02395          res_exp_desc->will_fold_later = FALSE;
02396       } 
02397 
02398       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
02399                     arg_info_list[info_idx1].ed.type_idx;
02400       ATD_POINTER(ATP_RSLT_IDX(*spec_idx)) = TRUE;
02401 
02402       tmp_dv_idx = gen_compiler_tmp(line, col, Priv, TRUE);
02403       ATD_TYPE_IDX(tmp_dv_idx) = ATD_TYPE_IDX(attr_idx);
02404       ATD_STOR_BLK_IDX(tmp_dv_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
02405       AT_SEMANTICS_DONE(tmp_dv_idx) = TRUE;
02406       ATD_ARRAY_IDX(tmp_dv_idx) = ATD_ARRAY_IDX(attr_idx);
02407       ATD_POINTER(tmp_dv_idx) = TRUE;
02408       ATD_IM_A_DOPE(tmp_dv_idx) = TRUE;
02409 
02410       gen_opnd(&dv_opnd, tmp_dv_idx, AT_Tbl_Idx, line, col);
02411       gen_dv_whole_def_init(&dv_opnd,
02412                             tmp_dv_idx,
02413                             Before);
02414 
02415       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02416       IR_RANK(ir_idx) = res_exp_desc->rank;
02417       res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02418       res_exp_desc->type = 
02419               TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
02420       res_exp_desc->linear_type = 
02421               TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
02422       res_exp_desc->pointer = TRUE;
02423       res_exp_desc->tmp_reference = TRUE;
02424 
02425       gen_opnd(&dv_opnd, 
02426                gen_ir(AT_Tbl_Idx, 
02427                       tmp_dv_idx,
02428                       Dv_Deref_Opr, 
02429                       res_exp_desc->type_idx, 
02430                       line, 
02431                       col,
02432                       NO_Tbl_Idx, 
02433                       NULL_IDX),
02434                IR_Tbl_Idx, 
02435                line, 
02436                col);
02437 
02438       if (res_exp_desc->rank > 0) {
02439          gen_whole_subscript(&dv_opnd, res_exp_desc);
02440       }
02441 
02442       OPND_IDX((*result_opnd)) = OPND_IDX(dv_opnd);
02443       OPND_FLD((*result_opnd)) = OPND_FLD(dv_opnd);
02444    }
02445 
02446    TRACE (Func_Exit, "null_intrinsic", NULL);
02447 
02448 }  /* null_intrinsic */
02449 
02450 
02451 
02452 /******************************************************************************\
02453 |*                                                                            *|
02454 |* Description:                                                               *|
02455 |*      Function    ANINT(A, KIND) intrinsic.                                 *|
02456 |*                                                                            *|
02457 |* Input parameters:                                                          *|
02458 |*      NONE                                                                  *|
02459 |*                                                                            *|
02460 |* Output parameters:                                                         *|
02461 |*      NONE                                                                  *|
02462 |*                                                                            *|
02463 |* Returns:                                                                   *|
02464 |*      NOTHING                                                               *|
02465 |*                                                                            *|
02466 \******************************************************************************/
02467 
02468 void    anint_intrinsic(opnd_type     *result_opnd,
02469                         expr_arg_type *res_exp_desc,
02470                         int           *spec_idx)
02471 {
02472    int            info_idx1;
02473    int            info_idx2;
02474    int            ir_idx;
02475    int            list_idx1;
02476    int            list_idx2;
02477 
02478 
02479    TRACE (Func_Entry, "anint_intrinsic", NULL);
02480 
02481    ir_idx = OPND_IDX((*result_opnd));
02482    list_idx1 = IR_IDX_R(ir_idx);
02483    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02484    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02485 
02486    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
02487       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02488       kind_to_linear_type(&((IL_OPND(list_idx2))),
02489                           ATP_RSLT_IDX(*spec_idx),
02490                           arg_info_list[info_idx2].ed.kind0seen,
02491                           arg_info_list[info_idx2].ed.kind0E0seen,
02492                           arg_info_list[info_idx2].ed.kind0D0seen,
02493                           ! arg_info_list[info_idx2].ed.kindnotconst);
02494    }
02495    else {
02496       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
02497       arg_info_list[info_idx1].ed.type_idx;
02498    }
02499 
02500    conform_check(0, 
02501                  ir_idx,
02502                  res_exp_desc,
02503                  spec_idx,
02504                  FALSE);
02505 
02506    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02507    IR_RANK(ir_idx) = res_exp_desc->rank;
02508    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02509    res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
02510 
02511    IR_OPR(ir_idx) = Anint_Opr;
02512    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02513    IR_OPND_R(ir_idx) = null_opnd;
02514    IR_LIST_CNT_L(ir_idx) = 1;
02515    IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX;
02516 
02517    /* must reset foldable and will_fold_later because there is no */
02518    /* folder for this intrinsic in constructors.                  */
02519 
02520    res_exp_desc->foldable = FALSE;
02521    res_exp_desc->will_fold_later = FALSE;
02522 
02523    TRACE (Func_Exit, "anint_intrinsic", NULL);
02524 
02525 }  /* anint_intrinsic */
02526 
02527 
02528 /******************************************************************************\
02529 |*                                                                            *|
02530 |* Description:                                                               *|
02531 |*      Function    NINT(A, KIND) intrinsic.                                  *|
02532 |*      Function    ININT(A) intrinsic.                                       *|
02533 |*      Function    JNINT(A) intrinsic.                                       *|
02534 |*      Function    KNINT(A) intrinsic.                                       *|
02535 |*                                                                            *|
02536 |* Input parameters:                                                          *|
02537 |*      NONE                                                                  *|
02538 |*                                                                            *|
02539 |* Output parameters:                                                         *|
02540 |*      NONE                                                                  *|
02541 |*                                                                            *|
02542 |* Returns:                                                                   *|
02543 |*      NOTHING                                                               *|
02544 |*                                                                            *|
02545 \******************************************************************************/
02546 
02547 void    nint_intrinsic(opnd_type     *result_opnd,
02548                        expr_arg_type *res_exp_desc,
02549                        int           *spec_idx)
02550 {
02551    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
02552    int            info_idx1;
02553    int            info_idx2;
02554    int            ir_idx;
02555    int            list_idx1;
02556    int            list_idx2;
02557    int      type_idx;
02558 
02559 
02560    TRACE (Func_Entry, "nint_intrinsic", NULL);
02561 
02562    ir_idx = OPND_IDX((*result_opnd));
02563    list_idx1 = IR_IDX_R(ir_idx);
02564    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02565    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02566 
02567    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
02568       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02569       kind_to_linear_type(&((IL_OPND(list_idx2))),
02570                           ATP_RSLT_IDX(*spec_idx),
02571                           arg_info_list[info_idx2].ed.kind0seen,
02572                           arg_info_list[info_idx2].ed.kind0E0seen,
02573                           arg_info_list[info_idx2].ed.kind0D0seen,
02574                           ! arg_info_list[info_idx2].ed.kindnotconst);
02575    }
02576    else {
02577       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
02578    }
02579 
02580    if (ATP_INTRIN_ENUM(*spec_idx) == Inint_Intrinsic) {
02581       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_2;
02582    }
02583    else if (ATP_INTRIN_ENUM(*spec_idx) == Jnint_Intrinsic) {
02584       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_4;
02585    }
02586    else if (ATP_INTRIN_ENUM(*spec_idx) == Knint_Intrinsic) {
02587       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
02588    }
02589 
02590    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02591 
02592    conform_check(0, 
02593                  ir_idx,
02594                  res_exp_desc,
02595                  spec_idx,
02596                  FALSE);
02597 
02598    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02599    IR_RANK(ir_idx) = res_exp_desc->rank;
02600    res_exp_desc->type_idx = type_idx;
02601    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
02602 
02603    if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
02604        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
02605                      arg_info_list[info_idx1].ed.type_idx,
02606                      NULL,
02607                      NULL_IDX,
02608                      folded_const,
02609                      &type_idx,
02610                      IR_LINE_NUM(ir_idx),
02611                      IR_COL_NUM(ir_idx),
02612                      1,
02613                      Nint_Opr)) {
02614 
02615       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
02616       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
02617                                                FALSE,
02618                                                folded_const);
02619       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
02620       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
02621       res_exp_desc->constant = TRUE;
02622       res_exp_desc->foldable = TRUE;
02623    }
02624    else {
02625       IR_OPR(ir_idx) = Nint_Opr;
02626       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02627       IR_OPND_R(ir_idx) = null_opnd;
02628       IR_LIST_CNT_L(ir_idx) = 1;
02629       IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX;
02630    }
02631 
02632    TRACE (Func_Exit, "nint_intrinsic", NULL);
02633 
02634 }  /* nint_intrinsic */
02635 
02636 
02637 /******************************************************************************\
02638 |*                                                                            *|
02639 |* Description:                                                               *|
02640 |*      Function    SIGN(A, B) intrinsic.                                     *|
02641 |*      Function    ISIGN(A, B) intrinsic.                                    *|
02642 |*      Function    IISIGN(A, B) intrinsic.                                   *|
02643 |*      Function    JISIGN(A, B) intrinsic.                                   *|
02644 |*      Function    KISIGN(A, B) intrinsic.                                   *|
02645 |*      Function    DSIGN(A, B) intrinsic.                                    *|
02646 |*      Function    QSIGN(A, B) intrinsic.                                    *|
02647 |*                                                                            *|
02648 |* Input parameters:                                                          *|
02649 |*      NONE                                                                  *|
02650 |*                                                                            *|
02651 |* Output parameters:                                                         *|
02652 |*      NONE                                                                  *|
02653 |*                                                                            *|
02654 |* Returns:                                                                   *|
02655 |*      NOTHING                                                               *|
02656 |*                                                                            *|
02657 \******************************************************************************/
02658 
02659 void    sign_intrinsic(opnd_type     *result_opnd,
02660                        expr_arg_type *res_exp_desc,
02661                        int           *spec_idx)
02662 {
02663    int            list_idx1;
02664    int            list_idx2;
02665    int            info_idx1;
02666    int            info_idx2;
02667    int            ir_idx;
02668    int            type_idx;
02669    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
02670 
02671 
02672    TRACE (Func_Entry, "sign_intrinsic", NULL);
02673 
02674    ir_idx = OPND_IDX((*result_opnd));
02675    list_idx1 = IR_IDX_R(ir_idx);
02676    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02677    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02678    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02679 
02680    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
02681    type_idx  = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02682 
02683 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02684    if (arg_info_list[info_idx1].ed.linear_type == Real_16) {
02685       ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE;
02686    }
02687    else {
02688       ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE;
02689    }
02690 # endif
02691 
02692    conform_check(0, 
02693                  ir_idx,
02694                  res_exp_desc,
02695                  spec_idx,
02696                  FALSE);
02697 
02698    IR_TYPE_IDX(ir_idx) = type_idx;
02699    IR_RANK(ir_idx) = res_exp_desc->rank;
02700    res_exp_desc->type_idx = type_idx;
02701    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
02702  
02703    if (arg_info_list[info_idx1].ed.linear_type != 
02704        arg_info_list[info_idx2].ed.linear_type) {
02705       PRINTMSG(IR_LINE_NUM(ir_idx), 774,  Error, 
02706                IR_COL_NUM(ir_idx));
02707    }
02708 
02709    if (!ATP_EXTERNAL_INTRIN(*spec_idx)) {
02710       if (arg_info_list[info_idx1].ed.type == Integer &&
02711           IL_FLD(list_idx1) == CN_Tbl_Idx &&
02712           IL_FLD(list_idx2) == CN_Tbl_Idx && 
02713           folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
02714                         arg_info_list[info_idx1].ed.type_idx,
02715                         (char *)&CN_CONST(IL_IDX(list_idx2)),
02716                         arg_info_list[info_idx2].ed.type_idx,
02717                         folded_const,
02718                         &type_idx,
02719                         IR_LINE_NUM(ir_idx),
02720                         IR_COL_NUM(ir_idx),
02721                         2,
02722                         Sign_Opr)) {
02723 
02724          OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
02725          OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
02726                                                   FALSE,
02727                                                   folded_const);
02728          OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
02729          OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
02730          res_exp_desc->constant = TRUE;
02731          res_exp_desc->foldable = TRUE;
02732       }
02733       else {
02734          IR_OPR(ir_idx) = Sign_Opr;
02735 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02736          if (on_off_flags.recognize_minus_zero &&
02737              arg_info_list[info_idx1].ed.type == Real) {
02738             IR_OPR(ir_idx) = Ieee_Copy_Sign_Opr;
02739          }
02740 # endif
02741          COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02742          IR_OPND_R(ir_idx) = null_opnd;
02743 
02744          if (arg_info_list[info_idx1].ed.type != Integer) {
02745             /* must reset foldable and will_fold_later because there is no */
02746             /* folder for this intrinsic in constructors.                  */
02747 
02748             res_exp_desc->foldable = FALSE;
02749             res_exp_desc->will_fold_later = FALSE;
02750          }
02751       }
02752    }
02753    else {
02754       /* must reset foldable and will_fold_later because there is no */
02755       /* folder for this intrinsic in constructors.                  */
02756 
02757       res_exp_desc->foldable = FALSE;
02758       res_exp_desc->will_fold_later = FALSE;
02759    }
02760 
02761    TRACE (Func_Exit, "sign_intrinsic", NULL);
02762 
02763 }  /* sign_intrinsic */
02764 
02765 
02766 /******************************************************************************\
02767 |*                                                                            *|
02768 |* Description:                                                               *|
02769 |*      Function    MODULO(A, P) intrinsic.                                   *|
02770 |*                                                                            *|
02771 |* Input parameters:                                                          *|
02772 |*      NONE                                                                  *|
02773 |*                                                                            *|
02774 |* Output parameters:                                                         *|
02775 |*      NONE                                                                  *|
02776 |*                                                                            *|
02777 |* Returns:                                                                   *|
02778 |*      NOTHING                                                               *|
02779 |*                                                                            *|
02780 \******************************************************************************/
02781 
02782 void    modulo_intrinsic(opnd_type     *result_opnd,
02783                          expr_arg_type *res_exp_desc,
02784                          int           *spec_idx)
02785 {
02786    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
02787    int            ir_idx;
02788    int            info_idx1;
02789    int            info_idx2;
02790    int            list_idx1;
02791    int            list_idx2;
02792    int            type_idx;
02793 
02794 
02795    TRACE (Func_Entry, "modulo_intrinsic", NULL);
02796 
02797    ir_idx = OPND_IDX((*result_opnd));
02798    list_idx1 = IR_IDX_R(ir_idx);
02799    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02800    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02801    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02802 
02803    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
02804    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02805 
02806    conform_check(0, 
02807                  ir_idx,
02808                  res_exp_desc,
02809                  spec_idx,
02810                  FALSE);
02811 
02812    IR_TYPE_IDX(ir_idx) = type_idx;
02813    IR_RANK(ir_idx) = res_exp_desc->rank;
02814    res_exp_desc->type_idx = type_idx;
02815    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
02816 
02817    if (arg_info_list[info_idx1].ed.linear_type !=
02818        arg_info_list[info_idx2].ed.linear_type) {
02819       PRINTMSG(IR_LINE_NUM(ir_idx), 774, Error,
02820                IR_COL_NUM(ir_idx));
02821    }
02822 
02823    if (arg_info_list[info_idx1].ed.type == Integer &&
02824        IL_FLD(list_idx1) == CN_Tbl_Idx &&
02825        IL_FLD(list_idx2) == CN_Tbl_Idx &&
02826        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
02827                      arg_info_list[info_idx1].ed.type_idx,
02828                      (char *)&CN_CONST(IL_IDX(list_idx2)),
02829                      arg_info_list[info_idx2].ed.type_idx,
02830                      folded_const,
02831                      &type_idx,
02832                      IR_LINE_NUM(ir_idx),
02833                      IR_COL_NUM(ir_idx),
02834                      2,
02835                      Modulo_Opr)) {
02836       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
02837       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
02838                                                FALSE,
02839                                                folded_const);
02840       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
02841       OPND_COL_NUM((*result_opnd))  = IR_COL_NUM(ir_idx);
02842       res_exp_desc->constant = TRUE;
02843       res_exp_desc->foldable = TRUE;
02844    }
02845    else {
02846       IR_OPR(ir_idx) = Modulo_Opr;
02847       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
02848       IR_OPND_R(ir_idx) = null_opnd;
02849 
02850       if (arg_info_list[info_idx1].ed.type != Integer) {
02851          /* must reset foldable and will_fold_later because there is no */
02852          /* folder for this intrinsic in constructors.                  */
02853 
02854          res_exp_desc->foldable = FALSE;
02855          res_exp_desc->will_fold_later = FALSE;
02856       }
02857    }
02858 
02859    TRACE (Func_Exit, "modulo_intrinsic", NULL);
02860 
02861 }  /* modulo_intrinsic */
02862 
02863 
02864 /******************************************************************************\
02865 |*                                                                            *|
02866 |* Description:                                                               *|
02867 |*      Function    SHIFT(I, J) intrinsic.                                    *|
02868 |*      Function    SHIFTL(I, J) intrinsic.                                   *|
02869 |*      Function    LSHIFT(I, POSITIVE_SHIFT) intrinsic.                      *|
02870 |*      Function    SHIFTR(I, J) intrinsic.                                   *|
02871 |*      Function    RSHIFT(I, NEGATIVE_SHIFT) intrinsic.                      *|
02872 |*      Function    SHIFTA(I, J) intrinsic.                                   *|
02873 |*                                                                            *|
02874 |* Input parameters:                                                          *|
02875 |*      NONE                                                                  *|
02876 |*                                                                            *|
02877 |* Output parameters:                                                         *|
02878 |*      NONE                                                                  *|
02879 |*                                                                            *|
02880 |* Returns:                                                                   *|
02881 |*      NOTHING                                                               *|
02882 |*                                                                            *|
02883 \******************************************************************************/
02884 
02885 void    shift_intrinsic(opnd_type     *result_opnd,
02886                         expr_arg_type *res_exp_desc,
02887                         int           *spec_idx)
02888 {
02889    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
02890    int            list_idx1;
02891    int            list_idx2;
02892 #ifdef KEY /* Bug 10177 */
02893    long     num = 0;
02894 #else /* KEY Bug 10177 */
02895    long     num;
02896 #endif /* KEY Bug 10177 */
02897    int            info_idx1;
02898    int            info_idx2;
02899    int            ir_idx;
02900 #ifdef KEY /* Bug 10177 */
02901    operator_type  opr = Null_Opr;
02902 #else /* KEY Bug 10177 */
02903    operator_type  opr;
02904 #endif /* KEY Bug 10177 */
02905    int      type_idx;
02906    int      cn_idx;
02907    int      line;
02908    int      column;
02909 
02910 
02911    TRACE (Func_Entry, "shift_intrinsic", NULL);
02912 
02913    ir_idx = OPND_IDX((*result_opnd));
02914    list_idx1 = IR_IDX_R(ir_idx);
02915    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
02916    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
02917    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
02918 
02919    if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
02920        (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const ||
02921         arg_info_list[info_idx1].ed.linear_type == Short_Char_Const)) {
02922 
02923       find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1),
02924                                 &line,
02925                                 &column);
02926 
02927       if (arg_info_list[info_idx1].ed.type == Character) {
02928          PRINTMSG(line, 161, Ansi, column);
02929       }
02930 
02931       type_idx = INTEGER_DEFAULT_TYPE;
02932 
02933       IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1),
02934                                                  type_idx,
02935                                                  line,
02936                                                  column);
02937 
02938       arg_info_list[info_idx1].ed.type_idx = type_idx;
02939       arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx);
02940       arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx);
02941    }
02942 
02943 
02944    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
02945 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02946    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
02947    if (arg_info_list[info_idx1].ed.type == Integer) {
02948       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
02949                               arg_info_list[info_idx1].ed.linear_type;
02950    }
02951 # endif
02952 
02953 
02954 # ifdef _TARGET32
02955    if (arg_info_list[info_idx1].ed.linear_type == Integer_8 ||
02956        arg_info_list[info_idx1].ed.linear_type == Typeless_8 ||
02957        arg_info_list[info_idx1].ed.linear_type == Real_8) {
02958       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8;
02959 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02960       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
02961 # endif
02962    }
02963 # endif
02964 
02965 
02966 # ifdef _TARGET_OS_MAX
02967    if (arg_info_list[info_idx1].ed.linear_type == Integer_1 ||
02968        arg_info_list[info_idx1].ed.linear_type == Integer_2 ||
02969        arg_info_list[info_idx1].ed.linear_type == Integer_4 ||
02970        arg_info_list[info_idx1].ed.linear_type == Typeless_4 ||
02971        arg_info_list[info_idx1].ed.linear_type == Real_4) {
02972       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4;
02973    }
02974 # endif
02975 
02976    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
02977 
02978    switch (ATP_INTRIN_ENUM(*spec_idx)) {
02979       case Shift_Intrinsic:
02980            opr = Shift_Opr;
02981            break;
02982 
02983       case Shifta_Intrinsic:
02984            opr = Shifta_Opr;
02985            break;
02986 
02987       case Lshift_Intrinsic:
02988       case Shiftl_Intrinsic:
02989            opr = Shiftl_Opr;
02990            break;
02991 
02992       case Rshift_Intrinsic:
02993       case Shiftr_Intrinsic:
02994            opr = Shiftr_Opr;
02995            break;
02996 
02997       default:
02998            PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal,
02999                     IR_COL_NUM(ir_idx),
03000                     "shift_intrinsic");
03001          break;
03002    }
03003 
03004    conform_check(0, 
03005                  ir_idx,
03006                  res_exp_desc,
03007                  spec_idx,
03008                  FALSE);
03009 
03010    switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) {
03011          case Integer_1:
03012          case Typeless_1:
03013               num = BITSIZE_INT1_F90;
03014               break;
03015 
03016          case Integer_2:
03017          case Typeless_2:
03018               num = BITSIZE_INT2_F90;
03019               break;
03020 
03021          case Integer_4:
03022          case Typeless_4:
03023          case Real_4:
03024               num = BITSIZE_INT4_F90;
03025               break;
03026 
03027          case Integer_8:
03028          case Typeless_8:
03029          case Real_8:
03030               num = BITSIZE_INT8_F90;
03031               break;
03032 
03033          default:
03034               PRINTMSG(IR_LINE_NUM(ir_idx), 179, Internal,
03035                        IR_COL_NUM(ir_idx),
03036                        "shift_intrinsic");
03037          break;
03038    }
03039 
03040    if (IL_FLD(list_idx2) == CN_Tbl_Idx) {
03041       if (compare_cn_and_value(IL_IDX(list_idx2), num, Gt_Opr) ||
03042           compare_cn_and_value(IL_IDX(list_idx2), 0, Lt_Opr)) {
03043          PRINTMSG(arg_info_list[info_idx2].line, 1062, Error,
03044                   arg_info_list[info_idx2].col);
03045       }
03046    }
03047 
03048    IR_RANK(ir_idx) = res_exp_desc->rank;
03049    IR_TYPE_IDX(ir_idx) = type_idx;
03050    res_exp_desc->type_idx = type_idx;
03051    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
03052 
03053    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
03054        IL_FLD(list_idx2) == CN_Tbl_Idx &&
03055        arg_info_list[info_idx1].ed.type != Real) {
03056 
03057       if (opr == Shifta_Opr) {
03058          if (CN_INT_TO_C(IL_IDX(list_idx2)) == 8 &&
03059              (arg_info_list[info_idx1].ed.linear_type == Integer_1 ||
03060               (arg_info_list[info_idx1].ed.type == Typeless &&
03061                TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 8) ||
03062               arg_info_list[info_idx1].ed.linear_type == Typeless_1)) {
03063 
03064             cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 7);
03065             IL_IDX(list_idx2) = cn_idx;
03066          }
03067 
03068          else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 16 &&
03069                   (arg_info_list[info_idx1].ed.linear_type == Integer_2 ||
03070                    (arg_info_list[info_idx1].ed.type == Typeless &&
03071                     TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 16) ||
03072                    arg_info_list[info_idx1].ed.linear_type == Typeless_2)) {
03073 
03074             cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 15);
03075 
03076             IL_IDX(list_idx2) = cn_idx;
03077          }
03078 
03079          else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 32 &&
03080                   (arg_info_list[info_idx1].ed.linear_type == Integer_4 ||
03081                    (arg_info_list[info_idx1].ed.type == Typeless &&
03082                     TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 32) ||
03083                    arg_info_list[info_idx1].ed.linear_type == Typeless_4)) {
03084 
03085             cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 31);
03086 
03087             IL_IDX(list_idx2) = cn_idx;
03088          }
03089 
03090          else if (CN_INT_TO_C(IL_IDX(list_idx2)) == 64 &&
03091                   (arg_info_list[info_idx1].ed.linear_type == Integer_8 ||
03092                    (arg_info_list[info_idx1].ed.type == Typeless &&
03093                     TYP_BIT_LEN(arg_info_list[info_idx1].ed.type_idx) == 64) ||
03094                    arg_info_list[info_idx1].ed.linear_type == Typeless_8)) {
03095 
03096             cn_idx = C_INT_TO_CN(arg_info_list[info_idx2].ed.type_idx, 63);
03097 
03098             IL_IDX(list_idx2) = cn_idx;
03099          }
03100       }
03101 
03102       if (folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
03103                         arg_info_list[info_idx1].ed.type_idx,
03104                         (char *)&CN_CONST(IL_IDX(list_idx2)),
03105                         arg_info_list[info_idx2].ed.type_idx,
03106                         folded_const,
03107                         &type_idx,
03108                         IR_LINE_NUM(ir_idx),
03109                         IR_COL_NUM(ir_idx),
03110                         2,
03111                         opr)) {
03112 
03113          OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
03114          OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
03115                                                   FALSE,
03116                                                   folded_const);
03117          OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
03118          OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
03119          res_exp_desc->constant = TRUE;
03120          res_exp_desc->foldable = TRUE;
03121       }
03122    }
03123    else {       
03124       IR_OPR(ir_idx) = opr;
03125       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
03126       IR_OPND_R(ir_idx) = null_opnd;
03127 
03128       if (arg_info_list[info_idx1].ed.type == Real) {
03129          /* must reset foldable and will_fold_later because there is no */
03130          /* folder for this intrinsic in constructors.                  */
03131 
03132          res_exp_desc->foldable = FALSE;
03133          res_exp_desc->will_fold_later = FALSE;
03134       }
03135    }
03136 
03137    TRACE (Func_Exit, "shift_intrinsic", NULL);
03138 
03139 }  /* shift_intrinsic */
03140 
03141 /******************************************************************************\
03142 |*                                                                            *|
03143 |* Description:                                                               *|
03144 |*      Function    NUM_IMAGES() intrinsic.                                   *|
03145 |*      Function    REM_IMAGES() intrinsic.                                   *|
03146 |*      Function    LOG2_IMAGES() intrinsic.                                  *|
03147 |*      Function    THIS_IMAGE([array[,dim]]) intrinsic.                      *|
03148 |*      Subroutine  SYNC_IMAGES([image]) intrinsic.                           *|
03149 |*                                                                            *|
03150 |* Input parameters:                                                          *|
03151 |*      NONE                                                                  *|
03152 |*                                                                            *|
03153 |* Output parameters:                                                         *|
03154 |*      NONE                                                                  *|
03155 |*                                                                            *|
03156 |* Returns:                                                                   *|
03157 |*      NOTHING                                                               *|
03158 |*                                                                            *|
03159 \******************************************************************************/
03160 
03161 void    num_images_intrinsic(opnd_type     *result_opnd,
03162                              expr_arg_type *res_exp_desc,
03163                              int           *spec_idx)
03164 {
03165    int            line;
03166    int            column;
03167    int            ir_idx;
03168    int            cn_idx;
03169    int            plus_idx;
03170    int            power_idx;
03171    int            div_idx;
03172    int            info_idx1;
03173    int            int_idx;
03174    int            mod_idx;
03175    int            list_idx1;
03176    int            list_idx2;
03177    opnd_type      opnd;
03178    int            opnd_line;
03179    int            opnd_col;
03180    int            l_log10_idx;
03181    int            r_log10_idx;
03182    float          point_five;
03183    float          f_two;
03184    int            sn_idx;
03185    int            attr_idx;
03186    expr_arg_type  loc_exp_desc;
03187 
03188 
03189    TRACE (Func_Entry, "num_images_intrinsic", NULL);
03190 
03191    ir_idx = OPND_IDX((*result_opnd));
03192    line = IR_LINE_NUM(ir_idx);
03193    column = IR_COL_NUM(ir_idx);
03194 
03195    if (ATP_INTRIN_ENUM(*spec_idx) != Sync_Images_Intrinsic) {
03196       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
03197       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03198    }
03199    else {
03200       IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
03201    }
03202 
03203    ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE;
03204 
03205    conform_check(0,
03206                  ir_idx,
03207                  res_exp_desc,
03208                  spec_idx,
03209                  FALSE);
03210 
03211    IR_RANK(ir_idx) = res_exp_desc->rank;
03212 
03213    if (ATP_INTRIN_ENUM(*spec_idx) == Rem_Images_Intrinsic) {
03214       ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE;
03215       point_five = 0.5;
03216 
03217 /* JEFFL - Do we need to convert endian? - BRIANJ */
03218 /* We could call arith to do 1/2 and then we would have it correct for sure. */
03219 
03220 /* JBL - this won't work when float is not the same as REAL_DEFAULT_TYPE - BHJ*/
03221 
03222       cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE,(long_type *)&point_five);
03223       OPND_FLD(opnd) = IR_Tbl_Idx;
03224       OPND_IDX(opnd) = ir_idx;
03225       copy_subtree(&opnd, &opnd);
03226       plus_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
03227                   Plus_Opr, REAL_DEFAULT_TYPE, line, column,
03228                      CN_Tbl_Idx, cn_idx);
03229 
03230       f_two = 2.0;
03231       cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE, (long_type *)&f_two);
03232 
03233       r_log10_idx = gen_ir(CN_Tbl_Idx, cn_idx,
03234                   Log_10_Opr, REAL_DEFAULT_TYPE, line, column,
03235                      NO_Tbl_Idx, NULL_IDX);
03236 
03237       l_log10_idx = gen_ir(IR_Tbl_Idx, plus_idx,
03238                   Log_10_Opr, REAL_DEFAULT_TYPE, line, column,
03239                      NO_Tbl_Idx, NULL_IDX);
03240 
03241 
03242       div_idx = gen_ir(IR_Tbl_Idx, l_log10_idx,
03243                   Div_Opr, REAL_DEFAULT_TYPE, line, column,
03244                      IR_Tbl_Idx, r_log10_idx);
03245 
03246       int_idx = gen_ir(IR_Tbl_Idx, div_idx,
03247                   Int_Opr, INTEGER_DEFAULT_TYPE, line, column,
03248                      NO_Tbl_Idx, NULL_IDX);
03249 
03250       cn_idx = CN_INTEGER_TWO_IDX;
03251 
03252       power_idx = gen_ir(CN_Tbl_Idx, cn_idx,
03253                   Power_Opr, INTEGER_DEFAULT_TYPE, line, column,
03254                         IR_Tbl_Idx, int_idx);
03255 
03256       OPND_FLD(opnd) = IR_Tbl_Idx;
03257       OPND_IDX(opnd) = ir_idx;
03258       copy_subtree(&opnd, &opnd);
03259       mod_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
03260                   Mod_Opr, INTEGER_DEFAULT_TYPE, line, column,
03261                      IR_Tbl_Idx, power_idx);
03262 
03263       IR_IDX_L(ir_idx) = mod_idx;
03264       IR_FLD_L(ir_idx) = IR_Tbl_Idx;
03265       IR_OPND_R(ir_idx) = null_opnd;
03266       IR_OPR(ir_idx) = Int_Opr;
03267    }
03268    else if (ATP_INTRIN_ENUM(*spec_idx) == Log2_Images_Intrinsic) {
03269       ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE;
03270       point_five = 0.5;
03271       cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE,(long_type *)&point_five);
03272 
03273       OPND_FLD(opnd) = IR_Tbl_Idx;
03274       OPND_IDX(opnd) = ir_idx;
03275       copy_subtree(&opnd, &opnd);
03276       plus_idx = gen_ir(OPND_FLD(opnd), OPND_IDX(opnd),
03277                   Plus_Opr, REAL_DEFAULT_TYPE, line, column,
03278                      CN_Tbl_Idx, cn_idx);
03279 
03280       f_two = 2.0;
03281       cn_idx = ntr_const_tbl(REAL_DEFAULT_TYPE, FALSE, (long_type *)&f_two);
03282 
03283       r_log10_idx = gen_ir(CN_Tbl_Idx, cn_idx,
03284                   Log_10_Opr, REAL_DEFAULT_TYPE, line, column,
03285                      NO_Tbl_Idx, NULL_IDX);
03286 
03287       l_log10_idx = gen_ir(IR_Tbl_Idx, plus_idx,
03288                   Log_10_Opr, REAL_DEFAULT_TYPE, line, column,
03289                      NO_Tbl_Idx, NULL_IDX);
03290 
03291       div_idx = gen_ir(IR_Tbl_Idx, l_log10_idx,
03292                   Div_Opr, REAL_DEFAULT_TYPE, line, column,
03293                      IR_Tbl_Idx, r_log10_idx);
03294 
03295       IR_IDX_L(ir_idx) = div_idx;
03296       IR_FLD_L(ir_idx) = IR_Tbl_Idx;
03297       IR_OPND_R(ir_idx) = null_opnd;
03298       IR_OPR(ir_idx) = Int_Opr;
03299    }
03300    else if (ATP_INTRIN_ENUM(*spec_idx) == This_Image_Intrinsic) {
03301 
03302       if (IR_LIST_CNT_R(ir_idx) > 0) {
03303 
03304          list_idx1 = IR_IDX_R(ir_idx);
03305          info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03306 
03307          if (IR_LIST_CNT_R(ir_idx) == 2) {
03308             list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
03309          }
03310 
03311          if (arg_info_list[info_idx1].ed.reference) {
03312             attr_idx = find_base_attr(&IL_OPND(list_idx1),
03313                                       &opnd_line, &opnd_col);
03314 
03315             if (AT_DCL_ERR(attr_idx)) {
03316                goto EXIT;
03317             }
03318 
03319             if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
03320                 ATD_PE_ARRAY_IDX(attr_idx) != NULL_IDX &&
03321                 IR_LIST_CNT_R(ir_idx) == 1 &&
03322                 BD_RANK(ATD_PE_ARRAY_IDX(attr_idx)) == 1) {
03323 
03324                /* change to this_image3 with dim == 1 */
03325 
03326                sn_idx = ATI_FIRST_SPECIFIC_IDX(ATP_INTERFACE_IDX(*spec_idx));
03327 
03328                while (sn_idx) {
03329                   if (ATP_NUM_DARGS(SN_ATTR_IDX(sn_idx)) == 2) {
03330                      break;
03331                   }
03332                   sn_idx = SN_SIBLING_LINK(sn_idx);
03333                }
03334 
03335                if (sn_idx != NULL_IDX) {
03336                   IR_IDX_L(ir_idx) = SN_ATTR_IDX(sn_idx);
03337                   *spec_idx = SN_ATTR_IDX(sn_idx);
03338                   ATP_EXTERNAL_INTRIN((*spec_idx)) = TRUE;
03339                   ATD_TYPE_IDX(ATP_RSLT_IDX((*spec_idx))) =
03340                                            INTEGER_DEFAULT_TYPE;
03341 
03342                   NTR_IR_LIST_TBL(list_idx2);
03343                   IL_NEXT_LIST_IDX(list_idx1) = list_idx2;
03344                   IL_ARG_DESC_VARIANT(list_idx2) = TRUE;
03345                   IR_LIST_CNT_R(ir_idx) += 1;
03346 
03347                   IL_FLD(list_idx2) = CN_Tbl_Idx;
03348                   IL_IDX(list_idx2) = CN_INTEGER_ONE_IDX;
03349                   IL_LINE_NUM(list_idx2) = line;
03350                   IL_COL_NUM(list_idx2) = column;
03351 
03352                   arg_info_list_base = arg_info_list_top;
03353                   arg_info_list_top = arg_info_list_base + 1;
03354 
03355                   if (arg_info_list_top >= arg_info_list_size) {
03356                      enlarge_info_list_table();
03357                   }
03358 
03359                   IL_ARG_DESC_IDX(list_idx2) = arg_info_list_top;
03360                   arg_info_list[arg_info_list_top] = init_arg_info;
03361                   arg_info_list[arg_info_list_top].ed.constant = TRUE;
03362                   arg_info_list[arg_info_list_top].ed.foldable = TRUE;
03363                   arg_info_list[arg_info_list_top].ed.type     = Integer;
03364                   arg_info_list[arg_info_list_top].ed.type_idx =
03365                                                     CG_INTEGER_DEFAULT_TYPE;
03366                   arg_info_list[arg_info_list_top].ed.linear_type =
03367                                                     CG_INTEGER_DEFAULT_TYPE;
03368                   arg_info_list[arg_info_list_top].line = line;
03369                   arg_info_list[arg_info_list_top].col = column;
03370                }
03371             }
03372          }
03373 
03374          if (! arg_info_list[info_idx1].ed.reference) {
03375             /* error, not a co-array */
03376             find_opnd_line_and_column(&IL_OPND(list_idx1),
03377                                       &opnd_line, &opnd_col);
03378             PRINTMSG(opnd_line, 1575, Error, opnd_col);
03379          }
03380          else {
03381             attr_idx = find_base_attr(&IL_OPND(list_idx1),
03382                                       &opnd_line, &opnd_col);
03383 
03384             if (AT_OBJ_CLASS(attr_idx) != Data_Obj ||
03385                 ATD_PE_ARRAY_IDX(attr_idx) == NULL_IDX) {
03386                /* error, not a co-array */
03387                PRINTMSG(opnd_line, 1575, Error, opnd_col);
03388             }
03389             else {
03390 
03391                if (ATD_ALLOCATABLE(attr_idx)) {
03392                   attr_idx = ATD_VARIABLE_TMP_IDX(attr_idx);
03393                }
03394 
03395                COPY_OPND(opnd, IL_OPND(list_idx1));
03396                generate_bounds_list(ATD_PE_ARRAY_IDX(attr_idx),
03397                                     &opnd,
03398                                     &loc_exp_desc);
03399                COPY_OPND(IL_OPND(list_idx1), opnd);
03400                arg_info_list[info_idx1].ed = loc_exp_desc;
03401 
03402             }
03403          }
03404       }
03405    }
03406 
03407 EXIT:
03408 
03409    /* must reset foldable and will_fold_later because there is no */
03410    /* folder for this intrinsic in constructors.                  */
03411 
03412    res_exp_desc->foldable = FALSE;
03413    res_exp_desc->will_fold_later = FALSE;
03414 
03415    TRACE (Func_Exit, "num_images_intrinsic", NULL);
03416 
03417 }  /* num_images_intrinsic */
03418 
03419 
03420 /******************************************************************************\
03421 |*                                                                            *|
03422 |* Description:                                                               *|
03423 |*      Function    LEADZ(I) intrinsic.                                       *|
03424 |*      Function    POPCNT(I) intrinsic.                                      *|
03425 |*      Function    POPPAR(I) intrinsic.                                      *|
03426 |*                                                                            *|
03427 |* Input parameters:                                                          *|
03428 |*      NONE                                                                  *|
03429 |*                                                                            *|
03430 |* Output parameters:                                                         *|
03431 |*      NONE                                                                  *|
03432 |*                                                                            *|
03433 |* Returns:                                                                   *|
03434 |*      NOTHING                                                               *|
03435 |*                                                                            *|
03436 \******************************************************************************/
03437 
03438 void    leadz_intrinsic(opnd_type     *result_opnd,
03439                         expr_arg_type *res_exp_desc,
03440                         int           *spec_idx)
03441 {
03442    int            ir_idx;
03443    int            list_idx1;
03444    int            info_idx1;
03445 
03446 
03447    TRACE (Func_Entry, "leadz_intrinsic", NULL);
03448 
03449    ir_idx = OPND_IDX((*result_opnd));
03450    list_idx1 = IR_IDX_R(ir_idx);
03451    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03452 
03453    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
03454 
03455    if (storage_bit_size_tbl[arg_info_list[info_idx1].ed.linear_type] > 64) {
03456       PRINTMSG(arg_info_list[info_idx1].line, 774,  Error, 
03457                arg_info_list[info_idx1].col);
03458    }
03459 
03460    conform_check(0, 
03461                  ir_idx,
03462                  res_exp_desc,
03463                  spec_idx,
03464                  FALSE);
03465 
03466    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03467    IR_RANK(ir_idx) = res_exp_desc->rank;
03468 
03469    if (ATP_INTRIN_ENUM(*spec_idx) == Popcnt_Intrinsic) {
03470       IR_OPR(ir_idx) = Popcnt_Opr;
03471    }
03472    else if (ATP_INTRIN_ENUM(*spec_idx) == Poppar_Intrinsic) {
03473       IR_OPR(ir_idx) = Poppar_Opr;
03474    }
03475    else {
03476       IR_OPR(ir_idx) = Leadz_Opr;
03477    }
03478 
03479    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
03480    IR_OPND_R(ir_idx) = null_opnd;
03481 
03482    /* must reset foldable and will_fold_later because there is no */
03483    /* folder for this intrinsic in constructors.                  */
03484 
03485    res_exp_desc->foldable = FALSE;
03486    res_exp_desc->will_fold_later = FALSE;
03487 
03488    TRACE (Func_Exit, "leadz_intrinsic", NULL);
03489 
03490 }  /* leadz_intrinsic */
03491 
03492 
03493 /******************************************************************************\
03494 |*                                                                            *|
03495 |* Description:                                                               *|
03496 |*      Function    NOT(I) intrinsic.                                         *|
03497 |*      Function    INOT(I) intrinsic.                                        *|
03498 |*      Function    JNOT(I) intrinsic.                                        *|
03499 |*      Function    KNOT(I) intrinsic.                                        *|
03500 |*      Function    COMPL(I) intrinsic.                                       *|
03501 |*                                                                            *|
03502 |* Input parameters:                                                          *|
03503 |*      NONE                                                                  *|
03504 |*                                                                            *|
03505 |* Output parameters:                                                         *|
03506 |*      NONE                                                                  *|
03507 |*                                                                            *|
03508 |* Returns:                                                                   *|
03509 |*      NOTHING                                                               *|
03510 |*                                                                            *|
03511 \******************************************************************************/
03512 
03513 void    not_intrinsic(opnd_type     *result_opnd,
03514                       expr_arg_type *res_exp_desc,
03515                       int           *spec_idx)
03516 {
03517    opnd_type      opnd;
03518    int            info_idx1;
03519    int            ir_idx;
03520    int            list_idx1;
03521    long     num;
03522    operator_type  opr;
03523    int            first_idx;
03524    int            cn_idx;
03525    int            cn_idx2;
03526    int            typeless_idx;
03527    int            second_idx;
03528    int            minus_idx;
03529    int            type_idx;
03530    int            not_idx;
03531    int            shiftl_idx;
03532    int            shiftr_idx;
03533    int      line;
03534    int      column;
03535 
03536 
03537    TRACE (Func_Entry, "not_intrinsic", NULL);
03538 
03539    ir_idx = OPND_IDX((*result_opnd));
03540    list_idx1 = IR_IDX_R(ir_idx);
03541    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03542 
03543    if (arg_info_list[info_idx1].ed.type == Logical) {
03544       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
03545       opr = Not_Opr;
03546    }
03547    else {
03548       if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
03549           (arg_info_list[info_idx1].ed.linear_type == 
03550                                                Short_Typeless_Const ||
03551            arg_info_list[info_idx1].ed.linear_type == 
03552                                                Short_Char_Const)) {
03553    
03554          find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1),
03555                                    &line,
03556                                    &column);
03557 
03558          if (arg_info_list[info_idx1].ed.type == Character) {
03559             PRINTMSG(line, 161, Ansi, column);
03560          }
03561 
03562          type_idx = INTEGER_DEFAULT_TYPE;
03563 
03564          IL_IDX(list_idx1) = cast_typeless_constant(IL_IDX(list_idx1),
03565                                                     type_idx,
03566                                                     line,
03567                                                     column);
03568 
03569          arg_info_list[info_idx1].ed.type_idx = type_idx;
03570          arg_info_list[info_idx1].ed.type = TYP_TYPE(type_idx);
03571          arg_info_list[info_idx1].ed.linear_type = TYP_LINEAR(type_idx);
03572       }
03573 
03574       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = 
03575       arg_info_list[info_idx1].ed.type_idx;
03576 
03577       if (ATP_INTRIN_ENUM(*spec_idx) == Compl_Intrinsic) {
03578          ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
03579 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03580          ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
03581          if (arg_info_list[info_idx1].ed.type == Integer) {
03582             ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) =
03583                               arg_info_list[info_idx1].ed.linear_type;
03584          }
03585 # endif
03586 
03587 
03588 # ifdef _TARGET32
03589          if ((arg_info_list[info_idx1].ed.linear_type == Integer_8) ||
03590              (arg_info_list[info_idx1].ed.linear_type == Typeless_8) ||
03591              (arg_info_list[info_idx1].ed.linear_type == Real_8)) { 
03592             ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8;
03593 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
03594               ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
03595 # endif
03596          }
03597 # endif
03598 
03599 # ifdef _TARGET_OS_MAX
03600          if (arg_info_list[info_idx1].ed.linear_type == Integer_1 ||
03601              arg_info_list[info_idx1].ed.linear_type == Integer_2 ||
03602              arg_info_list[info_idx1].ed.linear_type == Integer_4 ||
03603              arg_info_list[info_idx1].ed.linear_type == Typeless_4 ||
03604              arg_info_list[info_idx1].ed.linear_type == Real_4) {
03605             ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4;
03606          }
03607 # endif
03608       }
03609       opr = Bnot_Opr;
03610    }
03611 
03612    if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_8 ||
03613        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_8) {
03614       typeless_idx = Typeless_8;
03615    }
03616    else {
03617       typeless_idx = TYPELESS_DEFAULT_TYPE;
03618    }
03619 
03620 # ifdef _TARGET_OS_MAX
03621    if (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_1 ||
03622        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_2 ||
03623        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Typeless_4 ||
03624        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer_4) {
03625       typeless_idx = Typeless_4;
03626    }
03627 # endif
03628 
03629    conform_check(0, 
03630                  ir_idx,
03631                  res_exp_desc,
03632                  spec_idx,
03633                  FALSE);
03634 
03635    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03636    IR_RANK(ir_idx) = res_exp_desc->rank;
03637    res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx);
03638    res_exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx));
03639 
03640    if (opr == Not_Opr) {
03641       IR_OPR(ir_idx) = opr;
03642       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
03643       IR_OPND_R(ir_idx) = null_opnd;
03644    }
03645    else {
03646 
03647       line = IR_LINE_NUM(ir_idx);
03648       column = IR_COL_NUM(ir_idx);
03649 
03650       not_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1),
03651                        opr, typeless_idx, line, column,
03652                        NO_Tbl_Idx, NULL_IDX);
03653       num = storage_bit_size_tbl[TYP_LINEAR(ATD_TYPE_IDX(
03654                                             ATP_RSLT_IDX(*spec_idx)))];
03655 
03656       cn_idx = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num);
03657 
03658       switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) {
03659          case Integer_1:
03660               num = BITSIZE_INT1_F90;
03661               break;
03662 
03663          case Integer_2:
03664               num = BITSIZE_INT2_F90;
03665               break;
03666 
03667          case Integer_4:
03668          case Typeless_4:
03669               num = BITSIZE_INT4_F90;
03670               break;
03671 
03672          case Integer_8:
03673          case Typeless_8:
03674               num = BITSIZE_INT8_F90;
03675               break;
03676       }
03677 
03678       cn_idx2 = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, num);
03679 
03680       minus_idx = gen_ir(CN_Tbl_Idx, cn_idx,
03681                          Minus_Opr, CG_INTEGER_DEFAULT_TYPE, line, column,
03682                          CN_Tbl_Idx, cn_idx2);
03683 
03684       NTR_IR_LIST_TBL(first_idx);
03685       IL_FLD(first_idx) = IR_Tbl_Idx;
03686       IL_IDX(first_idx) = not_idx;
03687       NTR_IR_LIST_TBL(second_idx);
03688       IL_FLD(second_idx) = IR_Tbl_Idx;
03689       IL_IDX(second_idx) = minus_idx;
03690       IL_NEXT_LIST_IDX(first_idx) = second_idx;
03691 
03692       shiftl_idx = gen_ir(IL_Tbl_Idx, first_idx,
03693                           Shiftl_Opr, typeless_idx, line, column,
03694                           NO_Tbl_Idx, NULL_IDX);
03695 
03696       NTR_IR_LIST_TBL(first_idx);
03697       IL_FLD(first_idx) = IR_Tbl_Idx;
03698       IL_IDX(first_idx) = shiftl_idx;
03699       NTR_IR_LIST_TBL(second_idx);
03700       IL_FLD(second_idx) = IR_Tbl_Idx;
03701       IL_IDX(second_idx) = minus_idx;
03702       IL_NEXT_LIST_IDX(first_idx) = second_idx;
03703 
03704       shiftr_idx = gen_ir(IL_Tbl_Idx, first_idx,
03705                           Shiftr_Opr, typeless_idx, line, column,
03706                           NO_Tbl_Idx, NULL_IDX);
03707 
03708       if (TYP_TYPE(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx))) == Integer) {
03709          IR_OPR(shiftr_idx) = Shifta_Opr;
03710       }
03711 
03712       IR_OPR(ir_idx) = Cvrt_Opr;
03713       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03714       IR_FLD_L(ir_idx) = IR_Tbl_Idx;
03715       IR_IDX_L(ir_idx) = shiftr_idx;
03716       IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
03717       IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
03718       IR_OPND_R(ir_idx) = null_opnd;
03719 
03720       if (IL_FLD(list_idx1) == CN_Tbl_Idx) {
03721          COPY_OPND(opnd, (*result_opnd));
03722          fold_aggragate_expression(&opnd, res_exp_desc, FALSE);
03723          COPY_OPND((*result_opnd), opnd);
03724       }
03725    }
03726 
03727    TRACE (Func_Exit, "not_intrinsic", NULL);
03728 
03729 }  /* not_intrinsic */
03730 
03731 
03732 /******************************************************************************\
03733 |*                                                                            *|
03734 |* Description:                                                               *|
03735 |*      Function    AINT(A,KIND) intrinsic.                                   *|
03736 |*                                                                            *|
03737 |* Input parameters:                                                          *|
03738 |*      NONE                                                                  *|
03739 |*                                                                            *|
03740 |* Output parameters:                                                         *|
03741 |*      NONE                                                                  *|
03742 |*                                                                            *|
03743 |* Returns:                                                                   *|
03744 |*      NOTHING                                                               *|
03745 |*                                                                            *|
03746 \******************************************************************************/
03747 
03748 void    aint_intrinsic(opnd_type     *result_opnd,
03749                        expr_arg_type *res_exp_desc,
03750                        int           *spec_idx)
03751 {
03752    int            info_idx1;
03753    int            info_idx2;
03754    int            list_idx1;
03755    int            list_idx2;
03756    int            ir_idx;
03757 
03758 
03759    TRACE (Func_Entry, "aint_intrinsic", NULL);
03760 
03761    ir_idx = OPND_IDX((*result_opnd));
03762    list_idx1 = IR_IDX_R(ir_idx);
03763    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
03764    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03765 
03766    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
03767       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
03768       kind_to_linear_type(&((IL_OPND(list_idx2))),
03769                           ATP_RSLT_IDX(*spec_idx),
03770                           arg_info_list[info_idx2].ed.kind0seen,
03771                           arg_info_list[info_idx2].ed.kind0E0seen,
03772                           arg_info_list[info_idx2].ed.kind0D0seen,
03773                           ! arg_info_list[info_idx2].ed.kindnotconst);
03774    }
03775    else {
03776       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) =
03777       arg_info_list[info_idx1].ed.type_idx;
03778    }
03779 
03780    conform_check(0,
03781                  ir_idx,
03782                  res_exp_desc,
03783                  spec_idx,
03784                  FALSE);
03785 
03786    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03787    IR_RANK(ir_idx) = res_exp_desc->rank;
03788    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03789    res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
03790 
03791    IR_OPR(ir_idx) = Aint_Opr;
03792    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
03793    IR_OPND_R(ir_idx) = null_opnd;
03794    IR_LIST_CNT_L(ir_idx) = 1;
03795    IL_NEXT_LIST_IDX(IR_IDX_L(ir_idx)) = NULL_IDX;
03796 
03797    /* must reset foldable and will_fold_later because there is no */
03798    /* folder for this intrinsic in constructors.                  */
03799 
03800    res_exp_desc->foldable = FALSE;
03801    res_exp_desc->will_fold_later = FALSE;
03802 
03803    TRACE (Func_Exit, "aint_intrinsic", NULL);
03804 
03805 }  /* aint_intrinsic */
03806 
03807 
03808 /******************************************************************************\
03809 |*                                                                            *|
03810 |* Description:                                                               *|
03811 |*      Function    ILEN(I) intrinsic.                                        *|
03812 |*      JBL - you must add folding of this intrinsic in fold_drive.c          *|
03813 |*                                                                            *|
03814 |* Input parameters:                                                          *|
03815 |*      NONE                                                                  *|
03816 |*                                                                            *|
03817 |* Output parameters:                                                         *|
03818 |*      NONE                                                                  *|
03819 |*                                                                            *|
03820 |* Returns:                                                                   *|
03821 |*      NOTHING                                                               *|
03822 |*                                                                            *|
03823 \******************************************************************************/
03824 
03825 void    ilen_intrinsic(opnd_type     *result_opnd,
03826                        expr_arg_type *res_exp_desc,
03827                        int           *spec_idx)
03828 {
03829    int            info_idx1;
03830    int            ir_idx;
03831    int            list_idx1;
03832 
03833 
03834    TRACE (Func_Entry, "ilen_intrinsic", NULL);
03835 
03836    ir_idx = OPND_IDX((*result_opnd));
03837    list_idx1 = IR_IDX_R(ir_idx);
03838    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03839    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
03840 
03841    conform_check(0, 
03842                  ir_idx,
03843                  res_exp_desc,
03844                  spec_idx,
03845                  FALSE);
03846 
03847    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03848    IR_RANK(ir_idx) = res_exp_desc->rank;
03849    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03850    res_exp_desc->linear_type = 
03851        TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
03852 
03853    res_exp_desc->foldable = FALSE;
03854    res_exp_desc->will_fold_later = FALSE;
03855 
03856    /* set this flag so this opr is pulled off io lists */
03857    io_item_must_flatten = TRUE;
03858 
03859    TRACE (Func_Exit, "ilen_intrinsic", NULL);
03860 
03861 }  /* ilen_intrinsic */
03862 
03863 
03864 /******************************************************************************\
03865 |*                                                                            *|
03866 |* Description:                                                               *|
03867 |*      Function    DIM(X,Y) intrinsic.                                       *|
03868 |*      Function    DDIM(X,Y) intrinsic.                                      *|
03869 |*      Function    QDIM(X,Y) intrinsic.                                      *|
03870 |*                                                                            *|
03871 |* Input parameters:                                                          *|
03872 |*      NONE                                                                  *|
03873 |*                                                                            *|
03874 |* Output parameters:                                                         *|
03875 |*      NONE                                                                  *|
03876 |*                                                                            *|
03877 |* Returns:                                                                   *|
03878 |*      NOTHING                                                               *|
03879 |*                                                                            *|
03880 \******************************************************************************/
03881 
03882 void    dim_intrinsic(opnd_type     *result_opnd,
03883                       expr_arg_type *res_exp_desc,
03884                       int           *spec_idx)
03885 {
03886    int            info_idx1;
03887    int            info_idx2;
03888    int            arg1;
03889    int            arg2;
03890    int            arg3;
03891    int            ir_idx;
03892    int            gt_idx;
03893    int            type_idx;
03894    int            zero_idx;
03895    int            minus_idx;
03896    int            select_idx;
03897    int            list_idx1;
03898    int            list_idx2;
03899    int            line;
03900    int            column;
03901    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
03902 
03903 
03904    TRACE (Func_Entry, "dim_intrinsic", NULL);
03905 
03906    ir_idx = OPND_IDX((*result_opnd));
03907    list_idx1 = IR_IDX_R(ir_idx);
03908    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
03909    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
03910    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
03911    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
03912    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
03913 
03914    conform_check(0, 
03915                  ir_idx,
03916                  res_exp_desc,
03917                  spec_idx,
03918                  FALSE);
03919 
03920    IR_TYPE_IDX(ir_idx) = type_idx;
03921    IR_RANK(ir_idx) = res_exp_desc->rank;
03922    res_exp_desc->type_idx = type_idx;
03923    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
03924 
03925    if (arg_info_list[info_idx1].ed.linear_type !=
03926        arg_info_list[info_idx2].ed.linear_type) {
03927       PRINTMSG(IR_LINE_NUM(ir_idx), 774,  Error, 
03928                IR_COL_NUM(ir_idx));
03929    }
03930 
03931    if (arg_info_list[info_idx1].ed.type == Integer &&
03932        IL_FLD(list_idx1) == CN_Tbl_Idx &&
03933        IL_FLD(list_idx2) == CN_Tbl_Idx &&
03934        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
03935                      arg_info_list[info_idx1].ed.type_idx,
03936                      (char *)&CN_CONST(IL_IDX(list_idx2)),
03937                      arg_info_list[info_idx2].ed.type_idx,
03938                      folded_const,
03939                      &type_idx,
03940                      IR_LINE_NUM(ir_idx),
03941                      IR_COL_NUM(ir_idx),
03942                      2,
03943                      Dim_Opr)) {
03944       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
03945       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
03946                                                FALSE,
03947                                                folded_const);
03948       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
03949       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
03950       res_exp_desc->constant = TRUE;
03951       res_exp_desc->foldable = TRUE;
03952    }
03953    else {
03954       if (!ATP_EXTERNAL_INTRIN(*spec_idx)) {
03955       find_opnd_line_and_column((opnd_type *)&IL_OPND(list_idx1),
03956                                 &line,
03957                                 &column);
03958 
03959       gt_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1),
03960                   Gt_Opr, LOGICAL_DEFAULT_TYPE, line, column,
03961                       IL_FLD(list_idx2), IL_IDX(list_idx2));
03962 
03963       minus_idx = gen_ir(IL_FLD(list_idx1), IL_IDX(list_idx1),
03964                      Minus_Opr, arg_info_list[info_idx1].ed.type_idx, 
03965                          line, column,
03966                       IL_FLD(list_idx2), IL_IDX(list_idx2));
03967 
03968       zero_idx = (TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) == 
03969                   CG_INTEGER_DEFAULT_TYPE) ? CN_INTEGER_ZERO_IDX :
03970                   C_INT_TO_CN(arg_info_list[info_idx1].ed.type_idx, 0);
03971 
03972       NTR_IR_LIST_TBL(arg1);
03973       IL_ARG_DESC_VARIANT(arg1) = TRUE;
03974       NTR_IR_LIST_TBL(arg2);
03975       IL_ARG_DESC_VARIANT(arg2) = TRUE;
03976       NTR_IR_LIST_TBL(arg3);
03977       IL_ARG_DESC_VARIANT(arg3) = TRUE;
03978 
03979       /* link list together */
03980       IL_NEXT_LIST_IDX(arg1) = arg2;
03981       IL_NEXT_LIST_IDX(arg2) = arg3;
03982 
03983       IL_IDX(arg1) = minus_idx;
03984       IL_FLD(arg1) = IR_Tbl_Idx;
03985       IL_LINE_NUM(arg1) = IR_LINE_NUM(ir_idx);
03986       IL_COL_NUM(arg1)  = IR_COL_NUM(ir_idx);
03987       IL_IDX(arg2) = zero_idx;
03988       IL_FLD(arg2) = CN_Tbl_Idx;
03989       IL_LINE_NUM(arg2) = IR_LINE_NUM(ir_idx);
03990       IL_COL_NUM(arg2)  = IR_COL_NUM(ir_idx);
03991       IL_IDX(arg3) = gt_idx;
03992       IL_FLD(arg3) = IR_Tbl_Idx;
03993       IL_LINE_NUM(arg3) = IR_LINE_NUM(ir_idx);
03994       IL_COL_NUM(arg3)  = IR_COL_NUM(ir_idx);
03995 
03996       select_idx = gen_ir(IL_Tbl_Idx, arg1,
03997                           Cvmgt_Opr, 
03998                           arg_info_list[info_idx1].ed.type_idx, 
03999                           IR_LINE_NUM(ir_idx), 
04000                           IR_COL_NUM(ir_idx),
04001                           NO_Tbl_Idx, NULL_IDX);
04002 
04003       /* set this flag so this opr is pulled off io lists */
04004       io_item_must_flatten = TRUE;
04005  
04006       IR_LIST_CNT_L(select_idx) = 3;
04007 
04008       IR_OPR(ir_idx) = Cvrt_Opr;
04009       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04010       IR_IDX_L(ir_idx) = select_idx;
04011       IR_FLD_L(ir_idx) = IR_Tbl_Idx;
04012       IR_OPND_R(ir_idx) = null_opnd;
04013       }
04014 
04015       if (arg_info_list[info_idx1].ed.type != Integer) {
04016          /* must reset foldable and will_fold_later because there is no */
04017          /* folder for this intrinsic in constructors.                  */
04018 
04019          res_exp_desc->foldable = FALSE;
04020          res_exp_desc->will_fold_later = FALSE;
04021       }
04022    }
04023 
04024    TRACE (Func_Exit, "dim_intrinsic", NULL);
04025 
04026 }  /* dim_intrinsic */
04027 
04028 
04029 /******************************************************************************\
04030 |*                                                                            *|
04031 |* Description:                                                               *|
04032 |*      Function    MAX(A1, A2, ... A63) intrinsic.                           *|
04033 |*      Function    MIN(A1, A2, ... A63) intrinsic.                           *|
04034 |*                                                                            *|
04035 |* Input parameters:                                                          *|
04036 |*      NONE                                                                  *|
04037 |*                                                                            *|
04038 |* Output parameters:                                                         *|
04039 |*      NONE                                                                  *|
04040 |*                                                                            *|
04041 |* Returns:                                                                   *|
04042 |*      NOTHING                                                               *|
04043 |*                                                                            *|
04044 \******************************************************************************/
04045 
04046 void    max_intrinsic(opnd_type     *result_opnd,
04047                       expr_arg_type *res_exp_desc,
04048                       int           *spec_idx)
04049 {
04050    int            col   = 0; 
04051    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
04052    boolean        fold_it;
04053    boolean        casting_needed= FALSE;
04054    int            info_idx1;
04055    int            largest_linear_type;
04056    int            ir_idx;
04057    int            line    = 0;
04058    int            n_idx;
04059    operator_type  opr;
04060    opnd_type      opnd;
04061    int            t_idx;
04062    int            tmp_idx;
04063    int            type_idx;
04064 
04065 
04066    TRACE (Func_Entry, "max_intrinsic", NULL);
04067 
04068    ir_idx = OPND_IDX((*result_opnd));
04069    info_idx1 = IL_ARG_DESC_IDX(IR_IDX_R(ir_idx));
04070 
04071    conform_check(3, 
04072                  ir_idx,                 
04073                  res_exp_desc,
04074                  spec_idx,
04075                  FALSE);
04076 
04077 
04078    t_idx = IR_IDX_R(ir_idx);
04079    n_idx = IL_NEXT_LIST_IDX(t_idx);
04080 #ifdef KEY /* Bug 14010 */
04081    int first_il_idx = t_idx;
04082 #endif /* KEY Bug 14010 */
04083 
04084    largest_linear_type = arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.linear_type;
04085 
04086    fold_it = (IL_FLD(t_idx) == CN_Tbl_Idx);
04087 
04088    while ((n_idx != NULL_IDX) && (IL_IDX(n_idx) != NULL_IDX)) {
04089       if (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type !=
04090           arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type) {
04091          PRINTMSG(IR_LINE_NUM(ir_idx), 774,  Error, 
04092                   IR_COL_NUM(ir_idx));
04093          fold_it = FALSE;
04094          break;
04095       }
04096 
04097       if ((opt_flags.set_fastint_option || 
04098            opt_flags.set_allfastint_option) &&
04099           (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type == Integer)) { 
04100          if (opt_flags.set_allfastint_option || 
04101              (TYP_DESC(arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type_idx) == 
04102                                Default_Typed)) {
04103             casting_needed = TRUE;
04104          }
04105 
04106          if (opt_flags.set_allfastint_option || 
04107              (TYP_DESC(arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type_idx) == 
04108                                Default_Typed)) {
04109             casting_needed = TRUE;
04110          }
04111       }
04112 
04113       if (arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.linear_type !=
04114           arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type) {
04115          PRINTMSG(arg_info_list[IL_ARG_DESC_IDX(n_idx)].line, 1323, Ansi, 
04116                   arg_info_list[IL_ARG_DESC_IDX(n_idx)].col);
04117 
04118          casting_needed = TRUE;
04119          if (largest_linear_type <
04120              arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type) {
04121             largest_linear_type = 
04122                    arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.linear_type;
04123          }
04124       }
04125 
04126       fold_it = fold_it && (IL_FLD(n_idx) == CN_Tbl_Idx);
04127 
04128       t_idx = n_idx;
04129       n_idx = IL_NEXT_LIST_IDX(n_idx);
04130    }
04131 
04132    if (casting_needed) {
04133       t_idx = IR_IDX_R(ir_idx);
04134 
04135       while ((t_idx != NULL_IDX) && (IL_IDX(t_idx) != NULL_IDX)) {
04136          COPY_OPND(opnd, IL_OPND(t_idx));
04137          cast_to_type_idx(&opnd,
04138                           &arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed,
04139                           largest_linear_type);
04140          COPY_OPND(IL_OPND(t_idx), opnd);
04141 
04142          t_idx = IL_NEXT_LIST_IDX(t_idx);
04143       }
04144    }
04145 
04146 #ifdef KEY /* Bug 14010 */
04147    /*
04148     * First and second args must be present, so if a later actual argument is
04149     * an optional dummy belonging to the caller, and it is not present, then
04150     * substitute the first arg.
04151     */
04152    int count = 0;
04153    for (t_idx = IR_IDX_R(ir_idx); t_idx != NULL_IDX;
04154      t_idx = IL_NEXT_LIST_IDX(t_idx)) {
04155      if (++count > 2 && NULL_IDX != is_optional_dummy(t_idx)) {
04156        pass_dummy_or_default(t_idx, IL_FLD(first_il_idx), IL_IDX(first_il_idx),
04157    largest_linear_type, FALSE);
04158      }
04159    }
04160 #endif /* KEY Bug 14010 */
04161 
04162    if ((ATP_INTRIN_ENUM(*spec_idx) == Amax0_Intrinsic) ||
04163        (ATP_INTRIN_ENUM(*spec_idx) == Amin0_Intrinsic)) {
04164       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE;
04165    }
04166    else if ((ATP_INTRIN_ENUM(*spec_idx) == Max1_Intrinsic) ||
04167             (ATP_INTRIN_ENUM(*spec_idx) == Min1_Intrinsic)) {
04168       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
04169    }
04170    else {
04171       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = largest_linear_type;
04172    }
04173 
04174    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04175    res_exp_desc->linear_type = TYP_LINEAR(res_exp_desc->type_idx);
04176    res_exp_desc->type = TYP_TYPE(res_exp_desc->type_idx);
04177    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04178    IR_RANK(ir_idx) = res_exp_desc->rank;
04179    type_idx = res_exp_desc->type_idx;
04180 
04181    if (ATP_INTRIN_ENUM(*spec_idx) == Max_Intrinsic ||
04182        ATP_INTRIN_ENUM(*spec_idx) == Amax0_Intrinsic ||
04183        ATP_INTRIN_ENUM(*spec_idx) == Amax1_Intrinsic ||
04184        ATP_INTRIN_ENUM(*spec_idx) == Dmax1_Intrinsic ||
04185        ATP_INTRIN_ENUM(*spec_idx) == Max0_Intrinsic ||
04186        ATP_INTRIN_ENUM(*spec_idx) == Max1_Intrinsic) {
04187       IR_OPR(ir_idx) = Lt_Opr;
04188       opr = Max_Opr;
04189    }
04190    else {
04191       IR_OPR(ir_idx) = Gt_Opr;
04192       opr = Min_Opr;
04193    }
04194 
04195    if (fold_it &&
04196        res_exp_desc->type == Integer &&
04197        arg_info_list[info_idx1].ed.type == Integer) {
04198       t_idx = IR_IDX_R(ir_idx);
04199       n_idx = IL_NEXT_LIST_IDX(t_idx);
04200 
04201       while ((n_idx != NULL_IDX) && (IL_IDX(n_idx) != NULL_IDX)) {
04202          fold_it = folder_driver((char *)&CN_CONST(IL_IDX(t_idx)),
04203                              arg_info_list[IL_ARG_DESC_IDX(t_idx)].ed.type_idx,
04204                              (char *)&CN_CONST(IL_IDX(n_idx)),
04205                              arg_info_list[IL_ARG_DESC_IDX(n_idx)].ed.type_idx,
04206                              folded_const,
04207                              &type_idx,
04208                              line,
04209                              col,
04210                              2,
04211                              IR_OPR(ir_idx));
04212 
04213          if (THIS_IS_TRUE(folded_const, type_idx)) {
04214             t_idx = n_idx;
04215          }
04216 
04217 
04218          OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
04219          OPND_IDX((*result_opnd)) = ntr_const_tbl(res_exp_desc->type_idx,
04220                                                   FALSE,
04221                                                   &CN_CONST(IL_IDX(t_idx)));
04222          OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
04223          OPND_COL_NUM((*result_opnd))  = IR_COL_NUM(ir_idx);
04224          res_exp_desc->constant = TRUE;
04225          res_exp_desc->foldable = TRUE;
04226 
04227          n_idx = IL_NEXT_LIST_IDX(n_idx);
04228       }
04229    }
04230    else {
04231       tmp_idx = gen_ir(IR_FLD_R(ir_idx), IR_IDX_R(ir_idx),
04232                    opr, IR_TYPE_IDX(ir_idx), IR_LINE_NUM(ir_idx), 
04233                                              IR_COL_NUM(ir_idx),
04234                        NO_Tbl_Idx, NULL_IDX);
04235 
04236       IR_OPR(ir_idx) = Cvrt_Opr;
04237       IR_IDX_L(ir_idx) = tmp_idx;
04238       IR_FLD_L(ir_idx) = IR_Tbl_Idx;
04239       IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(ir_idx);
04240       IR_COL_NUM_L(ir_idx) = IR_COL_NUM(ir_idx);
04241       IR_OPND_R(ir_idx) = null_opnd;
04242 
04243       if (res_exp_desc->type != Integer) {
04244          /* must reset foldable and will_fold_later because there is no */
04245          /* folder for this intrinsic in constructors.                  */
04246 
04247          res_exp_desc->foldable = FALSE;
04248          res_exp_desc->will_fold_later = FALSE;
04249       }
04250    }
04251 
04252    TRACE (Func_Exit, "max_intrinsic", NULL);
04253 
04254 }  /* max_intrinsic */
04255 
04256 
04257 
04258 /******************************************************************************\
04259 |*                                                                            *|
04260 |* Description:                                                               *|
04261 |*      Function    RANGET(I) intrinsic.                                      *|
04262 |*      Function    RANSET(I) intrinsic.                                      *|
04263 |*                                                                            *|
04264 |* Input parameters:                                                          *|
04265 |*      NONE                                                                  *|
04266 |*                                                                            *|
04267 |* Output parameters:                                                         *|
04268 |*      NONE                                                                  *|
04269 |*                                                                            *|
04270 |* Returns:                                                                   *|
04271 |*      NOTHING                                                               *|
04272 |*                                                                            *|
04273 \******************************************************************************/
04274 
04275 void    ranget_intrinsic(opnd_type     *result_opnd,
04276                          expr_arg_type *res_exp_desc,
04277                          int           *spec_idx)
04278 {
04279    int      info_idx1;
04280    int            ir_idx;
04281    int            list_idx1;
04282    int            tmp_attr;
04283    int      unused1 = NULL_IDX;
04284    int      unused2 = NULL_IDX;
04285    opnd_type    old_opnd;
04286    opnd_type    base_opnd;
04287 
04288 
04289    TRACE (Func_Entry, "ranget_intrinsic", NULL);
04290 
04291    ir_idx = OPND_IDX((*result_opnd));
04292    list_idx1 = IR_IDX_R(ir_idx);
04293    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
04294    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
04295 
04296 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04297    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
04298 # endif
04299 
04300    conform_check(0, 
04301                  ir_idx,
04302                  res_exp_desc,
04303                  spec_idx,
04304                  FALSE);
04305 
04306    if (IL_IDX(list_idx1) == NULL_IDX) {  /* argument not present */
04307                                          /* insert one           */
04308       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04309       IR_RANK(ir_idx) = res_exp_desc->rank;
04310 
04311       tmp_attr = gen_compiler_tmp(IR_LINE_NUM(ir_idx),
04312                                   IR_COL_NUM(ir_idx),
04313                                   Priv, TRUE);
04314       ATD_STOR_BLK_IDX(tmp_attr) = SCP_SB_STACK_IDX(curr_scp_idx);
04315       ATD_TYPE_IDX(tmp_attr) = INTEGER_DEFAULT_TYPE;
04316 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04317       ATD_TYPE_IDX(tmp_attr) = Integer_8;
04318 # endif
04319       AT_SEMANTICS_DONE(tmp_attr) = TRUE;
04320 
04321       IL_FLD(list_idx1) = AT_Tbl_Idx;
04322       IL_IDX(list_idx1) = tmp_attr;
04323       IL_LINE_NUM(list_idx1) = IR_LINE_NUM(ir_idx);
04324       IL_COL_NUM(list_idx1) = IR_COL_NUM(ir_idx);
04325    }
04326    else {
04327       COPY_OPND(old_opnd, IL_OPND(list_idx1));
04328 
04329       if (! arg_info_list[info_idx1].ed.reference &&
04330           ! arg_info_list[info_idx1].ed.tmp_reference) {
04331      
04332          tmp_attr = create_tmp_asg(&old_opnd,
04333                       (expr_arg_type *)&(arg_info_list[info_idx1].ed),
04334                                    &base_opnd,
04335                                    Intent_In,
04336                                    TRUE,
04337                                    FALSE);
04338 
04339          COPY_OPND(old_opnd, base_opnd);
04340       }
04341 
04342       if (arg_info_list[info_idx1].ed.rank > 0) {
04343          make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2);
04344          COPY_OPND(IL_OPND(list_idx1), base_opnd);
04345       }
04346       else {
04347          COPY_OPND(IL_OPND(list_idx1), old_opnd);
04348       }
04349    }
04350 
04351 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04352    COPY_OPND(old_opnd, IL_OPND(list_idx1));
04353    cast_to_type_idx(&old_opnd, &arg_info_list[info_idx1].ed, Integer_8);
04354    COPY_OPND(IL_OPND(list_idx1), old_opnd);
04355 # else
04356    COPY_OPND(old_opnd, IL_OPND(list_idx1));
04357    cast_to_cg_default(&old_opnd, &(arg_info_list[info_idx1].ed));
04358    COPY_OPND(IL_OPND(list_idx1), old_opnd);
04359 # endif
04360 
04361    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04362    IR_RANK(ir_idx) = res_exp_desc->rank;
04363    if (ATP_INTRIN_ENUM(*spec_idx) == Ranget_Intrinsic) {
04364       IR_OPR(ir_idx) = Ranget_Opr;
04365    }
04366    else {
04367       IR_OPR(ir_idx) = Ranset_Opr;
04368    }
04369    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04370    IR_OPND_R(ir_idx) = null_opnd;
04371 
04372    /* must reset foldable and will_fold_later because there is no */
04373    /* folder for this intrinsic in constructors.                  */
04374 
04375    res_exp_desc->foldable = FALSE;
04376    res_exp_desc->will_fold_later = FALSE;
04377 
04378    TRACE (Func_Exit, "ranget_intrinsic", NULL);
04379 
04380 }  /* ranget_intrinsic */
04381 
04382 
04383 /******************************************************************************\
04384 |*                                                                            *|
04385 |* Description:                                                               *|
04386 |*      Function    RANF() intrinsic.                                         *|
04387 |*                                                                            *|
04388 |* Input parameters:                                                          *|
04389 |*      NONE                                                                  *|
04390 |*                                                                            *|
04391 |* Output parameters:                                                         *|
04392 |*      NONE                                                                  *|
04393 |*                                                                            *|
04394 |* Returns:                                                                   *|
04395 |*      NOTHING                                                               *|
04396 |*                                                                            *|
04397 \******************************************************************************/
04398 
04399 void    ranf_intrinsic(opnd_type     *result_opnd,
04400                        expr_arg_type *res_exp_desc,
04401                        int           *spec_idx)
04402 {
04403    int            ir_idx;
04404 
04405 
04406    TRACE (Func_Entry, "ranf_intrinsic", NULL);
04407 
04408    ir_idx = OPND_IDX((*result_opnd));
04409    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_8;
04410 
04411    conform_check(0, 
04412                  ir_idx,
04413                  res_exp_desc,
04414                  spec_idx,
04415                  FALSE);
04416 
04417    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04418    IR_RANK(ir_idx) = res_exp_desc->rank;
04419    IR_OPR(ir_idx) = Ranf_Opr;
04420 
04421    IR_OPND_L(ir_idx) = null_opnd;
04422    IR_OPND_R(ir_idx) = null_opnd;
04423 
04424    /* must reset foldable and will_fold_later because there is no */
04425    /* folder for this intrinsic in constructors.                  */
04426 
04427    res_exp_desc->foldable = FALSE;
04428    res_exp_desc->will_fold_later = FALSE;
04429    tree_has_ranf = TRUE;
04430 
04431    TRACE (Func_Exit, "ranf_intrinsic", NULL);
04432 
04433 }  /* ranf_intrinsic */
04434 
04435 
04436 /******************************************************************************\
04437 |*                                                                            *|
04438 |* Description:                                                               *|
04439 |*      Function    REAL(A, KIND) intrinsic.                                  *|
04440 |*      Function    FLOATI(A) intrinsic.                                      *|
04441 |*      Function    FLOATJ(A) intrinsic.                                      *|
04442 |*      Function    FLOATK(A) intrinsic.                                      *|
04443 |*      Function    QFLOAT(A) intrinsic.                                      *|
04444 |*      Function    QFLOATI(A) intrinsic.                                     *|
04445 |*      Function    QFLOATJ(A) intrinsic.                                     *|
04446 |*      Function    QFLOATK(A) intrinsic.                                     *|
04447 |*      Function    QREAL(A) intrinsic.                                       *|
04448 |*      Function    QEXT(A) intrinsic.                                        *|
04449 |*      Function    SNGL(A) intrinsic.                                        *|
04450 |*      Function    SNGLQ(A) intrinsic.                                       *|
04451 |*      Function    DBLE(A) intrinsic.                                        *|
04452 |*      Function    DBLEQ(A) intrinsic.                                       *|
04453 |*      Function    DFLOAT(A) intrinsic.                                      *|
04454 |*      Function    DFLOATI(A) intrinsic.                                     *|
04455 |*      Function    DFLOATJ(A) intrinsic.                                     *|
04456 |*      Function    DFLOATK(A) intrinsic.                                     *|
04457 |*      Function    DREAL(A) intrinsic.                                       *|
04458 |*                                                                            *|
04459 |* Input parameters:                                                          *|
04460 |*      NONE                                                                  *|
04461 |*                                                                            *|
04462 |* Output parameters:                                                         *|
04463 |*      NONE                                                                  *|
04464 |*                                                                            *|
04465 |* Returns:                                                                   *|
04466 |*      NOTHING                                                               *|
04467 |*                                                                            *|
04468 \******************************************************************************/
04469 
04470 void    real_intrinsic(opnd_type     *result_opnd,
04471                        expr_arg_type *res_exp_desc,
04472                        int           *spec_idx)
04473 {
04474    int      list_idx1;
04475    int      list_idx2;
04476    int      ir_idx;
04477    int      info_idx1;
04478    int      info_idx2;
04479 
04480 
04481    TRACE (Func_Entry, "real_intrinsic", NULL);
04482 
04483    ir_idx = OPND_IDX((*result_opnd));
04484    list_idx1 = IR_IDX_R(ir_idx);
04485    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
04486    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
04487 
04488    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
04489       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
04490       kind_to_linear_type(&((IL_OPND(list_idx2))),
04491                           ATP_RSLT_IDX(*spec_idx),
04492                           arg_info_list[info_idx2].ed.kind0seen,
04493                           arg_info_list[info_idx2].ed.kind0E0seen,
04494                           arg_info_list[info_idx2].ed.kind0D0seen,
04495                           ! arg_info_list[info_idx2].ed.kindnotconst);
04496    }
04497    else {
04498       switch (arg_info_list[info_idx1].ed.type) {
04499          case Integer:
04500          case Typeless:
04501          case Real:
04502             ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE;
04503             break;
04504 
04505          case Complex:
04506             switch (arg_info_list[info_idx1].ed.linear_type) {
04507                case Complex_4:
04508                   ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_4;
04509                   break;
04510                case Complex_8:
04511                   ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_8;
04512                   break;
04513                case Complex_16:
04514                   ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16;
04515                   break;
04516             }
04517             break;
04518       }
04519    }
04520 
04521    if (ATP_INTRIN_ENUM(*spec_idx) == Dfloat_Intrinsic ||
04522        ATP_INTRIN_ENUM(*spec_idx) == Dreal_Intrinsic ||
04523        ATP_INTRIN_ENUM(*spec_idx) == Dble_Intrinsic ||
04524        ATP_INTRIN_ENUM(*spec_idx) == Dbleq_Intrinsic ||
04525        ATP_INTRIN_ENUM(*spec_idx) == Dfloati_Intrinsic ||
04526        ATP_INTRIN_ENUM(*spec_idx) == Dfloatj_Intrinsic ||
04527        ATP_INTRIN_ENUM(*spec_idx) == Dfloatk_Intrinsic) {
04528       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_DEFAULT_TYPE;
04529    }
04530 
04531    if (ATP_INTRIN_ENUM(*spec_idx) == Qfloat_Intrinsic ||
04532        ATP_INTRIN_ENUM(*spec_idx) == Qext_Intrinsic ||
04533        ATP_INTRIN_ENUM(*spec_idx) == Qreal_Intrinsic ||
04534        ATP_INTRIN_ENUM(*spec_idx) == Qfloati_Intrinsic ||
04535        ATP_INTRIN_ENUM(*spec_idx) == Qfloatj_Intrinsic ||
04536        ATP_INTRIN_ENUM(*spec_idx) == Qfloatk_Intrinsic) {
04537       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16;
04538    }
04539 
04540    conform_check(0, 
04541                  ir_idx,
04542                  res_exp_desc,
04543                  spec_idx,
04544                  FALSE);
04545 
04546 #ifdef KEY /* Bug 12482 */
04547    if (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const) {
04548      typeless_to_type(list_idx1, ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
04549    }
04550 #endif /* KEY Bug 12482 */
04551 
04552    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04553    IR_RANK(ir_idx) = res_exp_desc->rank;
04554    IR_OPR(ir_idx) = Real_Opr;
04555 
04556    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04557    IR_OPND_R(ir_idx) = null_opnd;
04558    IR_LIST_CNT_L(ir_idx) = 1;
04559    IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX;
04560 
04561    /* must reset foldable and will_fold_later because there is no */
04562    /* folder for this intrinsic in constructors.                  */
04563 
04564    res_exp_desc->foldable = FALSE;
04565    res_exp_desc->will_fold_later = FALSE;
04566 
04567    TRACE (Func_Exit, "real_intrinsic", NULL);
04568 
04569 }  /* real_intrinsic */
04570 
04571 
04572 /******************************************************************************\
04573 |*                                                                            *|
04574 |* Description:                                                               *|
04575 |*      Function    MASK(I) intrinsic.                                        *|
04576 |*                                                                            *|
04577 |* Input parameters:                                                          *|
04578 |*      NONE                                                                  *|
04579 |*                                                                            *|
04580 |* Output parameters:                                                         *|
04581 |*      NONE                                                                  *|
04582 |*                                                                            *|
04583 |* Returns:                                                                   *|
04584 |*      NOTHING                                                               *|
04585 |*                                                                            *|
04586 \******************************************************************************/
04587 
04588 void    mask_intrinsic(opnd_type     *result_opnd,
04589                        expr_arg_type *res_exp_desc,
04590                        int           *spec_idx)
04591 {
04592    int      info_idx1;
04593    int            ir_idx;
04594    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
04595    int      list_idx1;
04596    int            type_idx;
04597 
04598 
04599    TRACE (Func_Entry, "mask_intrinsic", NULL);
04600 
04601    ir_idx = OPND_IDX((*result_opnd));
04602    list_idx1 = IR_IDX_R(ir_idx);
04603    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
04604    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = TYPELESS_DEFAULT_TYPE;
04605 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04606    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
04607    if (arg_info_list[info_idx1].ed.type == Integer) {
04608       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) =
04609                            arg_info_list[info_idx1].ed.linear_type;
04610    }
04611 # endif
04612 
04613    IR_RANK(ir_idx) = res_exp_desc->rank;
04614 
04615 # ifdef _TARGET32
04616    if (arg_info_list[info_idx1].ed.linear_type == Integer_8) {
04617       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_8;
04618 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04619       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Integer_8;
04620 # endif
04621    }
04622 # endif
04623 
04624 # ifdef _TARGET_OS_MAX
04625    if (arg_info_list[info_idx1].ed.linear_type == Integer_1 ||
04626        arg_info_list[info_idx1].ed.linear_type == Integer_2 ||
04627        arg_info_list[info_idx1].ed.linear_type == Integer_4) {
04628       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Typeless_4;
04629    }
04630 # endif
04631 
04632    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04633 
04634    conform_check(0,
04635                  ir_idx,
04636                  res_exp_desc,
04637                  spec_idx,
04638                  FALSE);
04639 
04640    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04641    if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
04642        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
04643                      arg_info_list[info_idx1].ed.type_idx,
04644                      NULL,
04645                      NULL_IDX,
04646                      folded_const,
04647                      &type_idx,
04648                      IR_LINE_NUM(ir_idx),
04649                      IR_COL_NUM(ir_idx),
04650                      1,
04651                      Mask_Opr)) {
04652       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
04653       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
04654                                                FALSE,
04655                                                folded_const);
04656       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
04657       OPND_COL_NUM((*result_opnd))  = IR_COL_NUM(ir_idx);
04658       res_exp_desc->constant = TRUE;
04659       res_exp_desc->foldable = TRUE;
04660    }
04661    else {
04662       IR_OPR(ir_idx) = Mask_Opr;
04663       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04664       IR_OPND_R(ir_idx) = null_opnd;
04665    }
04666 
04667    TRACE (Func_Exit, "mask_intrinsic", NULL);
04668 
04669 }  /* mask_intrinsic */
04670 
04671 
04672 /******************************************************************************\
04673 |*                                                                            *|
04674 |* Description:                                                               *|
04675 |*      Function    CONJG(Z) intrinsic.                                       *|
04676 |*                                                                            *|
04677 |* Input parameters:                                                          *|
04678 |*      NONE                                                                  *|
04679 |*                                                                            *|
04680 |* Output parameters:                                                         *|
04681 |*      NONE                                                                  *|
04682 |*                                                                            *|
04683 |* Returns:                                                                   *|
04684 |*      NOTHING                                                               *|
04685 |*                                                                            *|
04686 \******************************************************************************/
04687 
04688 void    conjg_intrinsic(opnd_type     *result_opnd,
04689                         expr_arg_type *res_exp_desc,
04690                         int           *spec_idx)
04691 {
04692    int            ir_idx;
04693    int            list_idx1;
04694    int            info_idx1;
04695 
04696 
04697    TRACE (Func_Entry, "conjg_intrinsic", NULL);
04698 
04699    ir_idx = OPND_IDX((*result_opnd));
04700    list_idx1 = IR_IDX_R(ir_idx);
04701    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
04702    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
04703 
04704    conform_check(0, 
04705                  ir_idx,
04706                  res_exp_desc,
04707                  spec_idx,
04708                  FALSE);
04709 
04710    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04711    IR_RANK(ir_idx) = res_exp_desc->rank;
04712    IR_OPR(ir_idx) = Conjg_Opr;
04713 
04714    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04715    IR_OPND_R(ir_idx) = null_opnd;
04716 
04717    /* must reset foldable and will_fold_later because there is no */
04718    /* folder for this intrinsic in constructors.                  */
04719 
04720    res_exp_desc->foldable = FALSE;
04721    res_exp_desc->will_fold_later = FALSE;
04722 
04723    TRACE (Func_Exit, "conjg_intrinsic", NULL);
04724 
04725 }  /* conjg_intrinsic */
04726 
04727 
04728 /******************************************************************************\
04729 |*                                                                            *|
04730 |* Description:                                                               *|
04731 |*      Function    DPROD(X, Y) intrinsic.                                    *|
04732 |*                                                                            *|
04733 |* Input parameters:                                                          *|
04734 |*      NONE                                                                  *|
04735 |*                                                                            *|
04736 |* Output parameters:                                                         *|
04737 |*      NONE                                                                  *|
04738 |*                                                                            *|
04739 |* Returns:                                                                   *|
04740 |*      NOTHING                                                               *|
04741 |*                                                                            *|
04742 \******************************************************************************/
04743 
04744 void    dprod_intrinsic(opnd_type     *result_opnd,
04745                         expr_arg_type *res_exp_desc,
04746                         int           *spec_idx)
04747 {
04748    int            ir_idx;
04749    int            list_idx1;
04750    int            list_idx2;
04751    int            info_idx1;
04752    int            info_idx2;
04753    opnd_type      opnd;
04754 
04755 
04756    TRACE (Func_Entry, "dprod_intrinsic", NULL);
04757 
04758    ir_idx = OPND_IDX((*result_opnd));
04759    list_idx1 = IR_IDX_R(ir_idx);
04760    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
04761    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
04762    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
04763    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_DEFAULT_TYPE;
04764 
04765    if (ATP_INTRIN_ENUM(*spec_idx) == Qprod_Intrinsic) {
04766       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Real_16;
04767    }
04768 
04769   if ((TYP_LINEAR(arg_info_list[info_idx1].ed.type_idx) != REAL_DEFAULT_TYPE) ||
04770       (TYP_LINEAR(arg_info_list[info_idx2].ed.type_idx) != REAL_DEFAULT_TYPE)) {
04771       PRINTMSG(IR_LINE_NUM(ir_idx), 361,  Error, 
04772                IR_COL_NUM(ir_idx));
04773    }
04774 
04775    conform_check(0, 
04776                  ir_idx,
04777                  res_exp_desc,
04778                  spec_idx,
04779                  FALSE);
04780 
04781    COPY_OPND(opnd, IL_OPND(list_idx1));
04782    cast_to_type_idx(&opnd, 
04783                     &arg_info_list[info_idx1].ed, 
04784                     ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
04785    COPY_OPND(IL_OPND(list_idx1), opnd);
04786 
04787    COPY_OPND(opnd, IL_OPND(list_idx2));
04788    cast_to_type_idx(&opnd, 
04789                     &arg_info_list[info_idx2].ed, 
04790                     ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
04791    COPY_OPND(IL_OPND(list_idx2), opnd);
04792 
04793 
04794    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04795    IR_RANK(ir_idx) = res_exp_desc->rank;
04796    IR_OPR(ir_idx) = Dprod_Opr;
04797 
04798    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04799    IR_OPND_R(ir_idx) = null_opnd;
04800 
04801    /* must reset foldable and will_fold_later because there is no */
04802    /* folder for this intrinsic in constructors.                  */
04803 
04804    res_exp_desc->foldable = FALSE;
04805    res_exp_desc->will_fold_later = FALSE;
04806 
04807    TRACE (Func_Exit, "dprod_intrinsic", NULL);
04808 
04809 }  /* dprod_intrinsic */
04810 
04811 
04812 /******************************************************************************\
04813 |*                                                                            *|
04814 |* Description:                                                               *|
04815 |*      Function    LENGTH(I) intrinsic.                                      *|
04816 |*                                                                            *|
04817 |* Input parameters:                                                          *|
04818 |*      NONE                                                                  *|
04819 |*                                                                            *|
04820 |* Output parameters:                                                         *|
04821 |*      NONE                                                                  *|
04822 |*                                                                            *|
04823 |* Returns:                                                                   *|
04824 |*      NOTHING                                                               *|
04825 |*                                                                            *|
04826 \******************************************************************************/
04827 
04828 void    length_intrinsic(opnd_type     *result_opnd,
04829                          expr_arg_type *res_exp_desc,
04830                          int           *spec_idx)
04831 {
04832    int            ir_idx;
04833 
04834 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04835    opnd_type    opnd;
04836 # endif
04837 
04838 
04839    TRACE (Func_Entry, "length_intrinsic", NULL);
04840 
04841    ir_idx = OPND_IDX((*result_opnd));
04842    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
04843 
04844    conform_check(0, 
04845                  ir_idx,
04846                  res_exp_desc,
04847                  spec_idx,
04848                  FALSE);
04849 
04850 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04851 #ifdef KEY /* Bug 4232 */
04852    /* See comment in erf_intrinsic() */
04853    if (!defining_stmt_func) {
04854 #endif /* KEY Bug 4232 */
04855      COPY_OPND(opnd, IR_OPND_R(ir_idx));
04856      final_arg_work(&opnd, IR_IDX_L(ir_idx), IR_LIST_CNT_R(ir_idx), NULL);
04857      COPY_OPND(IR_OPND_R(ir_idx), opnd);
04858 #ifdef KEY /* Bug 4232 */
04859    }
04860 #endif /* KEY Bug 4232 */
04861 
04862    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04863    IR_RANK(ir_idx) = res_exp_desc->rank;
04864    IR_OPR(ir_idx) = Length_Opr;
04865 
04866    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04867    IR_OPND_R(ir_idx) = null_opnd;
04868 # else 
04869    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04870    IR_RANK(ir_idx) = res_exp_desc->rank;
04871    IR_OPR(ir_idx) = Length_Opr;
04872 
04873    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04874    IR_OPND_R(ir_idx) = null_opnd;
04875 # endif
04876 
04877    /* must reset foldable and will_fold_later because there is no */
04878    /* folder for this intrinsic in constructors.                  */
04879 
04880    res_exp_desc->foldable = FALSE;
04881    res_exp_desc->will_fold_later = FALSE;
04882 
04883    TRACE (Func_Exit, "length_intrinsic", NULL);
04884 
04885 }  /* length_intrinsic */
04886 
04887 
04888 /******************************************************************************\
04889 |*                                                                            *|
04890 |* Description:                                                               *|
04891 |*      Function    GETPOS(I) intrinsic.                                      *|
04892 |*                                                                            *|
04893 |* Input parameters:                                                          *|
04894 |*      NONE                                                                  *|
04895 |*                                                                            *|
04896 |* Output parameters:                                                         *|
04897 |*      NONE                                                                  *|
04898 |*                                                                            *|
04899 |* Returns:                                                                   *|
04900 |*      NOTHING                                                               *|
04901 |*                                                                            *|
04902 \******************************************************************************/
04903 
04904 void    getpos_intrinsic(opnd_type     *result_opnd,
04905                          expr_arg_type *res_exp_desc,
04906                          int           *spec_idx)
04907 {
04908    int            ir_idx;
04909 
04910 
04911    TRACE (Func_Entry, "getpos_intrinsic", NULL);
04912 
04913    ir_idx = OPND_IDX((*result_opnd));
04914    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
04915 
04916    conform_check(0, 
04917                  ir_idx,
04918                  res_exp_desc,
04919                  spec_idx,
04920                  FALSE);
04921 
04922    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04923    IR_RANK(ir_idx) = res_exp_desc->rank;
04924    IR_OPR(ir_idx) = Getpos_Opr;
04925 
04926    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04927    IR_OPND_R(ir_idx) = null_opnd;
04928 
04929    /* must reset foldable and will_fold_later because there is no */
04930    /* folder for this intrinsic in constructors.                  */
04931 
04932    res_exp_desc->foldable = FALSE;
04933    res_exp_desc->will_fold_later = FALSE;
04934 
04935    TRACE (Func_Exit, "getpos_intrinsic", NULL);
04936 
04937 }  /* getpos_intrinsic */
04938 
04939 
04940 /******************************************************************************\
04941 |*                                                                            *|
04942 |* Description:                                                               *|
04943 |*      Function    UNIT(I) intrinsic.                                        *|
04944 |*                                                                            *|
04945 |* Input parameters:                                                          *|
04946 |*      NONE                                                                  *|
04947 |*                                                                            *|
04948 |* Output parameters:                                                         *|
04949 |*      NONE                                                                  *|
04950 |*                                                                            *|
04951 |* Returns:                                                                   *|
04952 |*      NOTHING                                                               *|
04953 |*                                                                            *|
04954 \******************************************************************************/
04955 
04956 void    unit_intrinsic(opnd_type     *result_opnd,
04957                        expr_arg_type *res_exp_desc,
04958                        int           *spec_idx)
04959 {
04960    int            ir_idx;
04961 
04962 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04963    opnd_type    opnd;
04964 # endif
04965 
04966 
04967    TRACE (Func_Entry, "unit_intrinsic", NULL);
04968 
04969    ir_idx = OPND_IDX((*result_opnd));
04970    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = REAL_DEFAULT_TYPE;
04971 
04972    conform_check(0, 
04973                  ir_idx,
04974                  res_exp_desc,
04975                  spec_idx,
04976                  FALSE);
04977 
04978 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
04979 #ifdef KEY /* Bug 4232 */
04980    /* See comment in erf_intrinsic() */
04981    if (!defining_stmt_func) {
04982 #endif /* KEY Bug 4232 */
04983      COPY_OPND(opnd, IR_OPND_R(ir_idx));
04984      final_arg_work(&opnd, IR_IDX_L(ir_idx), IR_LIST_CNT_R(ir_idx), NULL);
04985      COPY_OPND(IR_OPND_R(ir_idx), opnd);
04986 #ifdef KEY /* Bug 4232 */
04987    }
04988 #endif /* KEY Bug 4232 */
04989 
04990    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04991    IR_RANK(ir_idx) = res_exp_desc->rank;
04992    IR_OPR(ir_idx) = Unit_Opr;
04993 
04994    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
04995    IR_OPND_R(ir_idx) = null_opnd;
04996 # else
04997    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
04998    IR_RANK(ir_idx) = res_exp_desc->rank;
04999    IR_OPR(ir_idx) = Unit_Opr;
05000 
05001    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05002    IR_OPND_R(ir_idx) = null_opnd;
05003 # endif
05004 
05005    /* must reset foldable and will_fold_later because there is no */
05006    /* folder for this intrinsic in constructors.                  */
05007 
05008    res_exp_desc->foldable = FALSE;
05009    res_exp_desc->will_fold_later = FALSE;
05010 
05011    TRACE (Func_Exit, "unit_intrinsic", NULL);
05012 
05013 }  /* unit_intrinsic */
05014 
05015 
05016 /******************************************************************************\
05017 |*                                                                            *|
05018 |* Description:                                                               *|
05019 |*      Function    CMPLX(X, Y, KIND) intrinsic.                              *|
05020 |*                                                                            *|
05021 |* Input parameters:                                                          *|
05022 |*      NONE                                                                  *|
05023 |*                                                                            *|
05024 |* Output parameters:                                                         *|
05025 |*      NONE                                                                  *|
05026 |*                                                                            *|
05027 |* Returns:                                                                   *|
05028 |*      NOTHING                                                               *|
05029 |*                                                                            *|
05030 \******************************************************************************/
05031 
05032 void    cmplx_intrinsic(opnd_type     *result_opnd,
05033                         expr_arg_type *res_exp_desc,
05034                         int           *spec_idx)
05035 {
05036    int      column;
05037    int      line;
05038    int            list_idx1;
05039    int            list_idx2;
05040    int            list_idx3;
05041    int            info_idx1;
05042    int            info_idx2;
05043    int            info_idx3;
05044    int            ir_idx;
05045    int            list_idx;
05046    operator_type  opr;
05047 #ifdef KEY /* Bug 10177 */
05048    int            type_idx = 0;
05049 #else /* KEY Bug 10177 */
05050    int            type_idx;
05051 #endif /* KEY Bug 10177 */
05052    opnd_type    opnd;
05053 
05054 
05055    TRACE (Func_Entry, "cmplx_intrinsic", NULL);
05056 
05057    ir_idx = OPND_IDX((*result_opnd));
05058    list_idx1 = IR_IDX_R(ir_idx);
05059    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
05060    list_idx3 = IL_NEXT_LIST_IDX(list_idx2);
05061    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05062    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
05063    opr = Cmplx_Opr;
05064 
05065    if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) {
05066       info_idx3 = IL_ARG_DESC_IDX(list_idx3);
05067       kind_to_linear_type(&((IL_OPND(list_idx3))),
05068                           ATP_RSLT_IDX(*spec_idx),
05069                           arg_info_list[info_idx3].ed.kind0seen,
05070                           arg_info_list[info_idx3].ed.kind0E0seen,
05071                           arg_info_list[info_idx3].ed.kind0D0seen,
05072                           ! arg_info_list[info_idx3].ed.kindnotconst);
05073    }
05074    else {
05075       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = COMPLEX_DEFAULT_TYPE;
05076    }
05077 
05078    switch (TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)))) {
05079          case Complex_4:
05080             type_idx = Real_4;
05081             break;
05082 
05083          case Complex_8:
05084             type_idx = Real_8;
05085             break;
05086 
05087          case Complex_16:
05088             type_idx = Real_16;
05089             break;
05090    }
05091 
05092    if ((ATP_INTRIN_ENUM(*spec_idx) == Dcmplx_Intrinsic)  &&
05093        (on_off_flags.enable_double_precision)) {
05094       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = DOUBLE_COMPLEX_DEFAULT_TYPE;
05095    }
05096 
05097    if (ATP_INTRIN_ENUM(*spec_idx) == Qcmplx_Intrinsic) {
05098       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Complex_16;
05099    }
05100 
05101    conform_check(2, 
05102                  ir_idx,
05103                  res_exp_desc,
05104                  spec_idx,
05105                  FALSE);
05106 
05107 #ifdef KEY /* Bug 12482 */
05108    if (arg_info_list[info_idx1].ed.linear_type == Short_Typeless_Const) {
05109      typeless_to_type(list_idx1, type_idx);
05110    }
05111    if (list_idx2 != NULL_IDX &&
05112      arg_info_list[info_idx2].ed.linear_type == Short_Typeless_Const) {
05113      typeless_to_type(list_idx2, type_idx);
05114    }
05115 #endif /* KEY Bug 12482 */
05116 
05117    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05118    IR_RANK(ir_idx) = res_exp_desc->rank;
05119 
05120    if (arg_info_list[info_idx1].ed.type == Integer) { 
05121       COPY_OPND(opnd, IL_OPND(list_idx1));
05122       cast_to_type_idx(&opnd, &arg_info_list[info_idx1].ed, type_idx);
05123       COPY_OPND(IL_OPND(list_idx1), opnd);
05124    }
05125 
05126    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
05127       if (arg_info_list[info_idx2].ed.type == Integer) { 
05128          COPY_OPND(opnd, IL_OPND(list_idx2));
05129          cast_to_type_idx(&opnd, &arg_info_list[info_idx2].ed, type_idx);
05130          COPY_OPND(IL_OPND(list_idx2), opnd);
05131       }
05132 
05133       if (arg_info_list[info_idx1].ed.type == Complex) {
05134          find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx2),
05135                                    &line,
05136                                    &column);
05137          PRINTMSG(line, 738, Error, column);
05138       }
05139    }
05140    else {  /* Y is not present */
05141 
05142       if (arg_info_list[info_idx1].ed.type == Complex) {  /* X is complex */
05143          opr = Cvrt_Opr;
05144       }
05145       else { /* X is not Complex */
05146          IL_FLD(list_idx2) = CN_Tbl_Idx;
05147          IL_IDX(list_idx2) = cvrt_str_to_cn("0.0",
05148                                             REAL_DEFAULT_TYPE);
05149          IL_LINE_NUM(list_idx2) = IR_LINE_NUM(ir_idx);
05150          IL_COL_NUM(list_idx2)  = IR_COL_NUM(ir_idx);
05151       }
05152    }
05153 
05154    IR_OPR(ir_idx) = opr;
05155    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05156    IR_OPND_R(ir_idx) = null_opnd;
05157 
05158    if (opr == Cvrt_Opr) {
05159       IR_LIST_CNT_L(ir_idx) = 1;
05160       list_idx = IR_IDX_L(ir_idx);
05161       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
05162    }
05163    else {
05164       IR_LIST_CNT_L(ir_idx) = 2;
05165       list_idx = IR_IDX_L(ir_idx);
05166       list_idx = IL_NEXT_LIST_IDX(list_idx);
05167       IL_NEXT_LIST_IDX(list_idx) = NULL_IDX;
05168    }
05169 
05170 
05171    /* must reset foldable and will_fold_later because there is no */
05172    /* folder for this intrinsic in constructors.                  */
05173    
05174    res_exp_desc->foldable = FALSE;
05175    res_exp_desc->will_fold_later = FALSE;
05176 
05177    TRACE (Func_Exit, "cmplx_intrinsic", NULL);
05178 
05179 }  /* cmplx_intrinsic */
05180 
05181 
05182 /******************************************************************************\
05183 |*                                                                            *|
05184 |* Description:                                                               *|
05185 |*      Function    LEN(STRING) intrinsic.                                    *|
05186 |*                                                                            *|
05187 |* Input parameters:                                                          *|
05188 |*      NONE                                                                  *|
05189 |*                                                                            *|
05190 |* Output parameters:                                                         *|
05191 |*      NONE                                                                  *|
05192 |*                                                                            *|
05193 |* Returns:                                                                   *|
05194 |*      NOTHING                                                               *|
05195 |*                                                                            *|
05196 \******************************************************************************/
05197 
05198 void    len_intrinsic(opnd_type     *result_opnd,
05199                       expr_arg_type *res_exp_desc,
05200                       int           *spec_idx)
05201 {
05202    int      unused_idx;
05203    int            ir_idx;
05204    int            line;
05205    int            col;
05206 
05207 
05208    TRACE (Func_Entry, "len_intrinsic", NULL);
05209 
05210    ir_idx = OPND_IDX((*result_opnd));
05211    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
05212 
05213    conform_check(0, 
05214                  ir_idx,
05215                  res_exp_desc,
05216                  spec_idx,
05217                  TRUE);
05218 
05219    if (cmd_line_flags.runtime_substring &&
05220        IR_OPR(IL_IDX(IR_IDX_R(ir_idx))) == Substring_Opr) {
05221       gen_runtime_substring(IL_IDX(IR_IDX_R(ir_idx)));
05222    }
05223 
05224    res_exp_desc->rank = 0;
05225 
05226    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05227    IR_RANK(ir_idx) = res_exp_desc->rank;
05228    IR_OPR(ir_idx) = Clen_Opr;
05229   
05230    unused_idx = find_base_attr(&IL_OPND(IR_IDX_R(ir_idx)), &line, &col);
05231 
05232    COPY_OPND(IR_OPND_L(ir_idx), IL_OPND(IR_IDX_R(ir_idx)));
05233    IR_OPND_R(ir_idx) = null_opnd;
05234 
05235    fold_clen_opr(result_opnd, res_exp_desc);
05236 
05237    cast_opnd_to_type_idx(result_opnd, INTEGER_DEFAULT_TYPE);
05238    res_exp_desc->type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05239    res_exp_desc->linear_type = 
05240                       TYP_LINEAR(ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)));
05241 
05242    /* must reset will_fold_later because there is no */
05243    /* folder for this intrinsic in constructors.                  */
05244 
05245    res_exp_desc->will_fold_later = FALSE;
05246 
05247    TRACE (Func_Exit, "len_intrinsic", NULL);
05248 
05249 }  /* len_intrinsic */
05250 
05251 
05252 /******************************************************************************\
05253 |*                                                                            *|
05254 |* Description:                                                               *|
05255 |*      Function    ICHAR(C) intrinsic or IACHAR(C) intrinsic.                *|
05256 |*                                                                            *|
05257 |* Input parameters:                                                          *|
05258 |*      NONE                                                                  *|
05259 |*                                                                            *|
05260 |* Output parameters:                                                         *|
05261 |*      NONE                                                                  *|
05262 |*                                                                            *|
05263 |* Returns:                                                                   *|
05264 |*      NOTHING                                                               *|
05265 |*                                                                            *|
05266 \******************************************************************************/
05267 
05268 void    ichar_intrinsic(opnd_type     *result_opnd,
05269                         expr_arg_type *res_exp_desc,
05270                         int           *spec_idx)
05271 {
05272    int            ir_idx;
05273    int            info_idx1;
05274    int            list_idx1;
05275    long_type      cnst[MAX_WORDS_FOR_NUMERIC];
05276    int      type_idx;
05277 
05278 
05279    TRACE (Func_Entry, "ichar_intrinsic", NULL);
05280 
05281    ir_idx = OPND_IDX((*result_opnd));
05282    list_idx1 = IR_IDX_R(ir_idx);
05283    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05284    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
05285    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05286 
05287    conform_check(0, 
05288                  ir_idx,
05289                  res_exp_desc,
05290                  spec_idx,
05291                  FALSE);
05292 
05293    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05294    IR_RANK(ir_idx) = res_exp_desc->rank;
05295    res_exp_desc->type_idx = type_idx;
05296    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
05297 
05298    if ((OPND_FLD(arg_info_list[info_idx1].ed.char_len) == CN_Tbl_Idx) &&
05299        (CN_INT_TO_C(OPND_IDX(arg_info_list[info_idx1].ed.char_len)) != 1)) {
05300       PRINTMSG(IR_LINE_NUM(ir_idx), 327,  Ansi,
05301                IR_COL_NUM(ir_idx));
05302    }
05303 
05304    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
05305        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
05306                      arg_info_list[info_idx1].ed.type_idx,
05307                      NULL,
05308                      NULL_IDX,
05309                      cnst,
05310                      &type_idx,
05311                      IR_LINE_NUM(ir_idx),
05312                      IR_COL_NUM(ir_idx),
05313                      1,
05314                      Ichar_Opr)) {
05315       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
05316       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
05317                                                FALSE,
05318                                                cnst);
05319       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
05320       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
05321       res_exp_desc->constant = TRUE;
05322       res_exp_desc->foldable = TRUE;
05323    }
05324    else {
05325       IR_OPR(ir_idx) = Ichar_Opr;
05326       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05327       IR_OPND_R(ir_idx) = null_opnd;
05328    }
05329 
05330    TRACE (Func_Exit, "ichar_intrinsic", NULL);
05331 
05332 }  /* ichar_intrinsic */
05333 
05334 
05335 /******************************************************************************\
05336 |*                                                                            *|
05337 |* Description:                                                               *|
05338 |*      Function    CHAR(I, KIND) intrinsic or ACHAR(I) intrinsic.            *|
05339 |*                                                                            *|
05340 |* Input parameters:                                                          *|
05341 |*      NONE                                                                  *|
05342 |*                                                                            *|
05343 |* Output parameters:                                                         *|
05344 |*      NONE                                                                  *|
05345 |*                                                                            *|
05346 |* Returns:                                                                   *|
05347 |*      NOTHING                                                               *|
05348 |*                                                                            *|
05349 \******************************************************************************/
05350 
05351 void    char_intrinsic(opnd_type     *result_opnd,
05352                        expr_arg_type *res_exp_desc,
05353                        int           *spec_idx)
05354 {
05355    int            list_idx1;
05356    int            list_idx2;
05357    long_type      cnst[MAX_WORDS_FOR_NUMERIC];
05358    int            ir_idx;
05359    int            info_idx1;
05360    int            info_idx2;
05361    int      type_idx;
05362 
05363 
05364    TRACE (Func_Entry, "char_intrinsic", NULL);
05365 
05366    ir_idx = OPND_IDX((*result_opnd));
05367    list_idx1 = IR_IDX_R(ir_idx);
05368    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
05369    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05370 
05371    if ((list_idx2 != NULL_IDX) && (IL_IDX(list_idx2) != NULL_IDX)) {
05372       info_idx2 = IL_ARG_DESC_IDX(list_idx2);
05373       kind_to_linear_type(&((IL_OPND(list_idx2))),
05374                           ATP_RSLT_IDX(*spec_idx),
05375                           arg_info_list[info_idx2].ed.kind0seen,
05376                           arg_info_list[info_idx2].ed.kind0E0seen,
05377                           arg_info_list[info_idx2].ed.kind0D0seen,
05378                           ! arg_info_list[info_idx2].ed.kindnotconst);
05379    }
05380    else {
05381       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = Character_1;
05382    }
05383 
05384    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05385 
05386    conform_check(0, 
05387                  ir_idx,
05388                  res_exp_desc,
05389                  spec_idx,
05390                  FALSE);
05391 
05392    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05393    IR_RANK(ir_idx) = res_exp_desc->rank;
05394 
05395    res_exp_desc->char_len.fld = CN_Tbl_Idx;
05396    res_exp_desc->char_len.idx = CN_INTEGER_ONE_IDX;
05397    res_exp_desc->type_idx = type_idx;
05398    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
05399 
05400    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
05401        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
05402                      arg_info_list[info_idx1].ed.type_idx,
05403                      NULL,
05404                      NULL_IDX,
05405                      cnst,
05406                      &type_idx,
05407                      IR_LINE_NUM(ir_idx),
05408                      IR_COL_NUM(ir_idx),
05409                      1,
05410                      Char_Opr)) {
05411       if (compare_cn_and_value(IL_IDX(list_idx1), 255, Gt_Opr) ||
05412           compare_cn_and_value(IL_IDX(list_idx1), 0, Lt_Opr)) {
05413          PRINTMSG(arg_info_list[info_idx1].line, 999,  Error, 
05414                   arg_info_list[info_idx1].col);
05415       }
05416 
05417       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
05418       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
05419                                                FALSE,
05420                                                cnst);
05421       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
05422       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
05423       res_exp_desc->constant = TRUE;
05424       res_exp_desc->foldable = TRUE;
05425    }
05426    else {
05427       IR_OPR(ir_idx) = Char_Opr;
05428       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05429       IR_OPND_R(ir_idx) = null_opnd;
05430 
05431       IR_LIST_CNT_L(ir_idx) = 1;
05432       IL_NEXT_LIST_IDX(list_idx1) = NULL_IDX;
05433 
05434       /* set this flag so this opr is pulled off io lists */
05435       io_item_must_flatten = TRUE;
05436    }
05437 
05438 
05439    TRACE (Func_Exit, "char_intrinsic", NULL);
05440 
05441 }  /* char_intrinsic */
05442 
05443 
05444 /******************************************************************************\
05445 |*                                                                            *|
05446 |* Description:                                                               *|
05447 |*      Function    NEW_LINE(A) intrinsic                                     *|
05448 |*                                                                            *|
05449 |* Ignores the kind type of A and always returns CHARACTER_DEFAULT_TYPE.      *|
05450 |* Ignores the OS and always returns '\n'                                     *|
05451 |*                                                                            *|
05452 \******************************************************************************/
05453 
05454 void    newline_intrinsic(opnd_type     *result_opnd,
05455                        expr_arg_type *res_exp_desc,
05456                        int           *spec_idx)
05457 {
05458    int            list_idx1;
05459    long_type      cnst[MAX_WORDS_FOR_NUMERIC];
05460    int            ir_idx;
05461    int      type_idx;
05462 
05463 
05464    TRACE (Func_Entry, "char_intrinsic", NULL);
05465 
05466    ir_idx = OPND_IDX((*result_opnd));
05467    list_idx1 = IR_IDX_R(ir_idx);
05468 
05469    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CHARACTER_DEFAULT_TYPE;
05470 
05471    conform_check(0, 
05472                  ir_idx,
05473                  res_exp_desc,
05474                  spec_idx,
05475                  FALSE);
05476 
05477    IR_TYPE_IDX(ir_idx) = type_idx;
05478    IR_RANK(ir_idx) = res_exp_desc->rank;
05479 
05480    res_exp_desc->char_len.fld = CN_Tbl_Idx;
05481    res_exp_desc->char_len.idx = CN_INTEGER_ONE_IDX;
05482    res_exp_desc->type_idx = type_idx;
05483    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
05484 
05485    OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
05486    * (char *) cnst = '\n';
05487    OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx, FALSE, cnst);
05488    OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
05489    OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
05490    res_exp_desc->constant = TRUE;
05491    res_exp_desc->foldable = TRUE;
05492 
05493    TRACE (Func_Exit, "newline_intrinsic", NULL);
05494 
05495 }  /* newline_intrinsic */
05496 
05497 /******************************************************************************\
05498 |*                                                                            *|
05499 |* Description:                                                               *|
05500 |*      Function    INDEX(STRING, SUBSTRING, BACK) intrinsic.                 *|
05501 |*      Function    SCAN(STRING, SET, BACK) intrinsic.                        *|
05502 |*      Function    VERIFY(STRING, SET, BACK) intrinsic.                      *|
05503 |*                                                                            *|
05504 |* Input parameters:                                                          *|
05505 |*      NONE                                                                  *|
05506 |*                                                                            *|
05507 |* Output parameters:                                                         *|
05508 |*      NONE                                                                  *|
05509 |*                                                                            *|
05510 |* Returns:                                                                   *|
05511 |*      NOTHING                                                               *|
05512 |*                                                                            *|
05513 \******************************************************************************/
05514 
05515 void    index_intrinsic(opnd_type     *result_opnd,
05516                         expr_arg_type *res_exp_desc,
05517                         int           *spec_idx)
05518 {
05519    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
05520    int            cn_idx;
05521    long_type      cnst[MAX_WORDS_FOR_NUMERIC];
05522    int            ir_idx;
05523    int      info_idx1;
05524    int      info_idx2;
05525    int      info_idx3;
05526    int            list_idx1;
05527    int            list_idx2;
05528    int            list_idx3;
05529    int      type_idx;
05530    operator_type  opr;
05531    opnd_type    opnd;
05532 
05533 
05534    TRACE (Func_Entry, "index_intrinsic", NULL);
05535 
05536    ir_idx = OPND_IDX((*result_opnd));
05537    list_idx1 = IR_IDX_R(ir_idx);
05538    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
05539    list_idx3 = IL_NEXT_LIST_IDX(list_idx2);
05540    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05541    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
05542    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
05543 
05544    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05545 
05546    conform_check(3, 
05547                  ir_idx,
05548                  res_exp_desc,
05549                  spec_idx,
05550                  FALSE);
05551 
05552    IR_TYPE_IDX(ir_idx) = type_idx;
05553    IR_RANK(ir_idx) = res_exp_desc->rank;
05554    res_exp_desc->type_idx = type_idx;
05555    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
05556 
05557    if (IL_IDX(list_idx3) == NULL_IDX) { /* if BACK is not present */
05558       cn_idx = set_up_logical_constant(cnst,
05559                                        CG_LOGICAL_DEFAULT_TYPE,
05560                                        FALSE_VALUE,
05561                                        TRUE);
05562 
05563       IL_FLD(list_idx3) = CN_Tbl_Idx;
05564       IL_IDX(list_idx3) = cn_idx;
05565       IL_LINE_NUM(list_idx3) = IR_LINE_NUM(ir_idx);
05566       IL_COL_NUM(list_idx3)  = IR_COL_NUM(ir_idx);
05567 
05568       arg_info_list_base = arg_info_list_top;
05569       arg_info_list_top = arg_info_list_base + 1;
05570 
05571       if (arg_info_list_top >= arg_info_list_size) {
05572          enlarge_info_list_table();
05573       }
05574 
05575       IL_ARG_DESC_IDX(list_idx3) = arg_info_list_top;
05576       arg_info_list[arg_info_list_top] = init_arg_info;
05577       arg_info_list[arg_info_list_top].ed.type_idx = CG_LOGICAL_DEFAULT_TYPE;
05578       arg_info_list[arg_info_list_top].ed.type = Logical;
05579       arg_info_list[arg_info_list_top].ed.linear_type= CG_LOGICAL_DEFAULT_TYPE;
05580       arg_info_list[arg_info_list_top].line = IR_LINE_NUM(ir_idx);
05581       arg_info_list[arg_info_list_top].col = IR_COL_NUM(ir_idx);
05582    }
05583 #ifdef KEY /* Bug 10410 */
05584    else if (NULL_IDX != is_optional_dummy(list_idx3)) {
05585      pass_dummy_or_default_const(list_idx3,
05586        set_up_logical_constant(cnst, CG_LOGICAL_DEFAULT_TYPE, FALSE_VALUE,
05587          TRUE),
05588        FALSE);
05589    }
05590 #endif /* KEY Bug 10410 */
05591 
05592    info_idx3 = IL_ARG_DESC_IDX(list_idx3);
05593 
05594    if (ATP_INTRIN_ENUM(*spec_idx) == Index_Intrinsic) {
05595       opr = Index_Opr;
05596    }
05597    else if (ATP_INTRIN_ENUM(*spec_idx) == Verify_Intrinsic) {
05598       opr = Verify_Opr;
05599    }
05600    else {
05601       opr = Scan_Opr;
05602 # ifdef _TARGET_OS_MAX
05603       ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE;
05604 # endif
05605    }
05606 
05607    if ((list_idx3 != NULL_IDX) && (IL_IDX(list_idx3) != NULL_IDX)) {
05608       COPY_OPND(opnd, IL_OPND(list_idx3));
05609       cast_to_cg_default(&opnd, &(arg_info_list[info_idx3].ed));
05610       COPY_OPND(IL_OPND(list_idx3), opnd);
05611    }
05612 
05613    if (IL_FLD(list_idx1) == CN_Tbl_Idx &&
05614        IL_FLD(list_idx2) == CN_Tbl_Idx &&
05615        IL_FLD(list_idx3) == CN_Tbl_Idx &&
05616        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
05617                      arg_info_list[info_idx1].ed.type_idx,
05618                      (char *)&CN_CONST(IL_IDX(list_idx2)),
05619                      arg_info_list[info_idx2].ed.type_idx,
05620                      folded_const,
05621                      &type_idx,
05622                      IR_LINE_NUM(ir_idx),
05623                      IR_COL_NUM(ir_idx),
05624                      3,
05625                      opr,
05626                      (char *)&CN_CONST(IL_IDX(list_idx3)),
05627                      (long)arg_info_list[info_idx3].ed.type_idx)) {
05628       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
05629       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
05630                                                FALSE,
05631                                                folded_const);
05632       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
05633       OPND_COL_NUM((*result_opnd)) = IR_COL_NUM(ir_idx);
05634       ATP_EXTERNAL_INTRIN(*spec_idx) = FALSE;
05635       res_exp_desc->constant = TRUE;
05636       res_exp_desc->foldable = TRUE;
05637    }
05638    else {
05639       if (!ATP_EXTERNAL_INTRIN(*spec_idx)) {
05640          IR_OPR(ir_idx) = opr;
05641          COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05642          IR_OPND_R(ir_idx) = null_opnd;
05643       }
05644    }
05645 
05646    TRACE (Func_Exit, "index_intrinsic", NULL);
05647 
05648 }  /* index_intrinsic */
05649 
05650 
05651 /******************************************************************************\
05652 |*                                                                            *|
05653 |* Description:                                                               *|
05654 |*      Function    LGE(STRING_A, STRING_B) intrinsic.                        *|
05655 |*      Function    LGT(STRING_A, STRING_B) intrinsic.                        *|
05656 |*      Function    LLE(STRING_A, STRING_B) intrinsic.                        *|
05657 |*      Function    LLT(STRING_A, STRING_B) intrinsic.                        *|
05658 |*                                                                            *|
05659 |* Input parameters:                                                          *|
05660 |*      NONE                                                                  *|
05661 |*                                                                            *|
05662 |* Output parameters:                                                         *|
05663 |*      NONE                                                                  *|
05664 |*                                                                            *|
05665 |* Returns:                                                                   *|
05666 |*      NOTHING                                                               *|
05667 |*                                                                            *|
05668 \******************************************************************************/
05669 
05670 void    lge_intrinsic(opnd_type     *result_opnd,
05671                       expr_arg_type *res_exp_desc,
05672                       int           *spec_idx)
05673 {
05674    int            ir_idx;
05675    int            list_idx1;
05676    int            list_idx2;
05677    int      info_idx1;
05678    int      info_idx2;
05679    long_type      folded_const[MAX_WORDS_FOR_NUMERIC];
05680    int      type_idx;
05681 
05682 
05683    TRACE (Func_Entry, "lge_intrinsic", NULL);
05684 
05685    ir_idx = OPND_IDX((*result_opnd));
05686    list_idx1 = IR_IDX_R(ir_idx);
05687    list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
05688    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05689    info_idx2 = IL_ARG_DESC_IDX(list_idx2);
05690 
05691    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = LOGICAL_DEFAULT_TYPE;
05692    type_idx = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05693 
05694    conform_check(0, 
05695                  ir_idx,
05696                  res_exp_desc,
05697                  spec_idx,
05698                  FALSE);
05699 
05700    IR_TYPE_IDX(ir_idx) = type_idx;
05701    IR_RANK(ir_idx) = res_exp_desc->rank;
05702    res_exp_desc->type_idx = type_idx;
05703    res_exp_desc->linear_type = TYP_LINEAR(type_idx);
05704 
05705    if (ATP_INTRIN_ENUM(*spec_idx) == Lge_Intrinsic) {
05706       IR_OPR(ir_idx) = Ge_Opr;
05707    }
05708    else if (ATP_INTRIN_ENUM(*spec_idx) == Llt_Intrinsic) {
05709       IR_OPR(ir_idx) = Lt_Opr;
05710    }
05711    else if (ATP_INTRIN_ENUM(*spec_idx) == Lle_Intrinsic) {
05712       IR_OPR(ir_idx) = Le_Opr;
05713    }
05714    else {
05715       IR_OPR(ir_idx) = Gt_Opr;
05716    }
05717 
05718    if (IL_FLD(list_idx1) == CN_Tbl_Idx && 
05719        IL_FLD(list_idx2) == CN_Tbl_Idx &&
05720        folder_driver((char *)&CN_CONST(IL_IDX(list_idx1)),
05721                      arg_info_list[info_idx1].ed.type_idx,
05722                      (char *)&CN_CONST(IL_IDX(list_idx2)),
05723                      arg_info_list[info_idx2].ed.type_idx,
05724                      folded_const,
05725                      &type_idx,
05726                      IR_LINE_NUM(ir_idx),
05727                      IR_COL_NUM(ir_idx),
05728                      2,
05729                      IR_OPR(ir_idx))) {
05730       OPND_FLD((*result_opnd)) = CN_Tbl_Idx;
05731       OPND_IDX((*result_opnd)) = ntr_const_tbl(type_idx,
05732                                                FALSE,
05733                                                folded_const);
05734       OPND_LINE_NUM((*result_opnd)) = IR_LINE_NUM(ir_idx);
05735       OPND_COL_NUM((*result_opnd))  = IR_COL_NUM(ir_idx);
05736       res_exp_desc->constant = TRUE;
05737       res_exp_desc->foldable = TRUE;
05738    }
05739    else {
05740       COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
05741       IR_OPND_R(ir_idx) = null_opnd;
05742    }
05743 
05744    TRACE (Func_Exit, "lge_intrinsic", NULL);
05745 
05746 }  /* lge_intrinsic */
05747 
05748 
05749 #ifdef KEY /* Bug 14150 */
05750 /*
05751  * Check argument of ISO_C_BINDING function c_loc or c_funloc
05752  *
05753  * which_intrinsic  C_Funloc_Intrinsic or C_Loc_Iso_Intrinsic
05754  * attr_idx   AT_Tbl_Idx for argument to c_loc or c_funloc
05755  * info_idx   Index into arg_info_list for this argument
05756  * return   error message number, or 0 for no error
05757  */
05758 static int
05759 c_loc_iso_arg_check(intrinsic_type which_intrinsic, int attr_idx,
05760   int info_idx) {
05761   int found_error = 0;
05762   if (which_intrinsic == C_Funloc_Intrinsic &&
05763     (AT_OBJ_CLASS(attr_idx) != Pgm_Unit ||
05764       (ATP_PGM_UNIT(attr_idx) != Subroutine &&
05765        ATP_PGM_UNIT(attr_idx) != Function &&
05766        ATP_PGM_UNIT(attr_idx) != Pgm_Unknown) ||
05767        !AT_BIND_ATTR(attr_idx))) {
05768      found_error = 700;
05769   }
05770   else if (which_intrinsic == C_Loc_Iso_Intrinsic) {
05771     if (AT_OBJ_CLASS(attr_idx) != Data_Obj) {
05772       found_error = 700;
05773     }
05774     else {
05775       int allocatable = arg_info_list[info_idx].ed.allocatable;
05776       int pointer = arg_info_list[info_idx].ed.pointer;
05777       int target = arg_info_list[info_idx].ed.target;
05778       int rank = arg_info_list[info_idx].ed.rank;
05779       found_error = (target || pointer) ? 1692 : 418;
05780       /* F2003 15.1.2.5 (1) */
05781       if ((target && interoperable_variable(attr_idx)) || /* (1a) */
05782   (allocatable && target &&
05783    check_interoperable_type(attr_idx, TRUE, FALSE)) || /* (1b) */
05784   (rank == 0 && pointer &&
05785    check_interoperable_type(attr_idx, TRUE, FALSE))) { /* (1c) */
05786   found_error = 0;
05787       }
05788       /* F2003 15.1.2.5 (2) */
05789       if (found_error && rank == 0 && no_length_type_param(attr_idx)) {
05790   if (((!allocatable) && (!pointer) && target) || /* (a) */
05791     (allocatable && target) || /* (b) */
05792     pointer) { /* (c) */
05793     found_error = 0;
05794   }
05795       }
05796     }
05797   }
05798   return found_error;
05799 }
05800 #endif /* KEY Bug 14150 */
05801 
05802 /******************************************************************************\
05803 |*                                                                            *|
05804 |* Description:                                                               *|
05805 |*      Function    LOC(I) intrinsic.                                         *|
05806 |*      Function    CLOC(C) intrinsic.                                        *|
05807 |*      Function    C_LOC(X) intrinsic (traditional Cray).                    *|
05808 |*      Function    C_LOC(X) intrinsic (iso_c_binding).                 *|
05809 |*      Function    C_FUNLOC(X) intrinsic.                                    *|
05810 |*                                                                            *|
05811 |* Input parameters:                                                          *|
05812 |*      NONE                                                                  *|
05813 |*                                                                            *|
05814 |* Output parameters:                                                         *|
05815 |*      NONE                                                                  *|
05816 |*                                                                            *|
05817 |* Returns:                                                                   *|
05818 |*      NOTHING                                                               *|
05819 |*                                                                            *|
05820 \******************************************************************************/
05821 
05822 void    loc_intrinsic(opnd_type     *result_opnd,
05823                       expr_arg_type *res_exp_desc,
05824                       int           *spec_idx)
05825 {
05826    opnd_type    base_opnd;
05827    int            ir_idx;
05828    int            attr_idx;
05829    int            info_idx1;
05830    int            list_idx1;
05831    opnd_type    old_opnd;
05832    int      unused1 = NULL_IDX;
05833    int      unused2 = NULL_IDX;
05834 
05835 
05836    TRACE (Func_Entry, "loc_intrinsic", NULL);
05837 
05838    ir_idx = OPND_IDX((*result_opnd));
05839    list_idx1 = IR_IDX_R(ir_idx);
05840    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
05841 #ifdef KEY /* Bug 14150 */
05842    intrinsic_type which = ATP_INTRIN_ENUM(*spec_idx);
05843    if (which == C_Loc_Iso_Intrinsic || which == C_Funloc_Intrinsic) {
05844      /* Type is already set correctly */
05845    }
05846    else
05847 #endif /* KEY Bug 14150 */
05848    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ptr_8;
05849 
05850    if (ATP_INTRIN_ENUM(*spec_idx) == Cloc_Intrinsic) {
05851       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8;
05852    }
05853 
05854    if (ATP_INTRIN_ENUM(*spec_idx) == C_Loc_Intrinsic &&
05855        arg_info_list[info_idx1].ed.type == Character) {
05856       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8;
05857    }
05858 
05859    if ((strcmp(AT_OBJ_NAME_PTR(*spec_idx), "LOC@") == 0) &&
05860        arg_info_list[info_idx1].ed.type == Character) {
05861       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8;
05862    }
05863 
05864    conform_check(0, 
05865                  ir_idx,
05866                  res_exp_desc,
05867                  spec_idx,
05868                  TRUE);
05869 
05870    res_exp_desc->rank = 0;
05871 
05872    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05873    IR_RANK(ir_idx) = res_exp_desc->rank;
05874 
05875 
05876 # ifdef _TARGET32
05877    if (arg_info_list[info_idx1].ed.linear_type == Integer_8 ||
05878        arg_info_list[info_idx1].ed.linear_type == Real_8 ||
05879        arg_info_list[info_idx1].ed.linear_type == Logical_8) {
05880 
05881       CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
05882       TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr;
05883       TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8;
05884       TYP_PTR_INCREMENT(TYP_WORK_IDX) = 64;
05885       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = ntr_type_tbl();
05886       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05887    }
05888 # endif
05889 
05890 # ifdef _TARGET_OS_MAX
05891    if (arg_info_list[info_idx1].ed.linear_type == Integer_4 ||
05892        arg_info_list[info_idx1].ed.linear_type == Real_4 ||
05893        arg_info_list[info_idx1].ed.linear_type == Logical_4) {
05894 
05895       CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
05896       TYP_TYPE(TYP_WORK_IDX) = CRI_Ptr;
05897       TYP_LINEAR(TYP_WORK_IDX) = CRI_Ptr_8;
05898       TYP_PTR_INCREMENT(TYP_WORK_IDX) = 32;
05899       ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = ntr_type_tbl();
05900       IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
05901    }
05902 # endif
05903 
05904 
05905    res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx);
05906    res_exp_desc->type = TYP_TYPE(IR_TYPE_IDX(ir_idx));
05907    res_exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx));
05908 
05909    if (IL_FLD(list_idx1) == AT_Tbl_Idx ||
05910        (IL_FLD(list_idx1) == IR_Tbl_Idx &&
05911         (IR_OPR(IL_IDX(list_idx1)) == Whole_Subscript_Opr ||
05912          IR_OPR(IL_IDX(list_idx1)) == Whole_Substring_Opr ||
05913          IR_OPR(IL_IDX(list_idx1)) == Struct_Opr ||
05914          IR_OPR(IL_IDX(list_idx1)) == Dv_Deref_Opr ||
05915          IR_OPR(IL_IDX(list_idx1)) == Subscript_Opr ||
05916          IR_OPR(IL_IDX(list_idx1)) == Substring_Opr ||
05917          IR_OPR(IL_IDX(list_idx1)) == Section_Subscript_Opr))) {
05918       attr_idx = find_base_attr(&IL_OPND(list_idx1), &unused1, &unused2);
05919 
05920 #ifdef KEY /* Bug 14150 */
05921       intrinsic_type which_intrinsic = ATP_INTRIN_ENUM(*spec_idx);
05922       if (which_intrinsic == C_Loc_Iso_Intrinsic ||
05923   which_intrinsic == C_Funloc_Intrinsic) {
05924   int found_error = (which_intrinsic == C_Loc_Iso_Intrinsic) ?
05925     c_loc_iso_arg_check(which_intrinsic, attr_idx, info_idx1) :
05926     (AT_BIND_ATTR(attr_idx) ? 0 : 1692);
05927   if (found_error) {
05928     PRINTMSG(arg_info_list[info_idx1].line, found_error, Error,
05929       arg_info_list[info_idx1].col, AT_OBJ_NAME_PTR(*spec_idx));
05930   }
05931   /* For now, call external procedure because giving Loc_Opr a result
05932    * type of type(c_ptr) or type(c_funptr) blows up elsewhere in the
05933    * front end. Sigh. See also table entry in p_driver.c */
05934   goto EXIT;
05935       }
05936 #endif /* KEY Bug 14150 */
05937 
05938       if (AT_OBJ_CLASS(attr_idx) == Pgm_Unit) {
05939          PRINTMSG(arg_info_list[info_idx1].line, 779, Error,
05940                   arg_info_list[info_idx1].col, AT_OBJ_NAME_PTR(attr_idx));
05941          goto EXIT;
05942       }
05943 
05944 
05945       if ((AT_OBJ_CLASS(attr_idx) == Data_Obj) && ATD_AUXILIARY(attr_idx)) {
05946          PRINTMSG(arg_info_list[info_idx1].line, 990,  Error, 
05947                   arg_info_list[info_idx1].col);
05948          goto EXIT;
05949       }
05950    }
05951    else {
05952       PRINTMSG(arg_info_list[info_idx1].line, 779,  Error, 
05953                arg_info_list[info_idx1].col);
05954       goto EXIT;
05955    }
05956 
05957    IR_OPR(ir_idx) = Loc_Opr;
05958 
05959    COPY_OPND(old_opnd, IL_OPND(IR_IDX_R(ir_idx)));
05960 
05961    unused1 = 0;
05962    unused2 = 0;
05963 
05964    make_base_subtree(&old_opnd, &base_opnd, &unused1, &unused2);
05965 
05966    COPY_OPND(IR_OPND_L(ir_idx), base_opnd);
05967 
05968    IR_OPND_R(ir_idx) = null_opnd;
05969 
05970 EXIT:
05971 
05972    /* must reset foldable and will_fold_later because there is no */
05973    /* folder for this intrinsic in constructors.                  */
05974 
05975    res_exp_desc->foldable = FALSE;
05976    res_exp_desc->will_fold_later = FALSE;
05977 
05978    TRACE (Func_Exit, "loc_intrinsic", NULL);
05979 
05980 }  /* loc_intrinsic */
05981 #ifdef KEY /* Bug 14150 */
05982 
05983 /*
05984  * For c_f_pointer(), return false if number of elements in "shape" argument
05985  * doesn't match rank of "fptr" argument
05986  * shape  shape[0] of argument "shape"
05987  * rank2  rank of argument "fptr"
05988  */
05989 static boolean
05990 compare_length(opnd_type shape, int rank2) {
05991   if (OPND_FLD(shape) != CN_Tbl_Idx) {
05992     return TRUE; /* Can't check */
05993   }
05994   return compare_cn_and_value(OPND_IDX(shape), rank2, Eq_Opr);
05995 }
05996 /******************************************************************************\
05997 |*                                                                            *|
05998 |* Description:                                                               *|
05999 |*      Function    C_F_POINTER(CPTR, FPTR [, SHAPE]) intrinsic.              *|
06000 |*      Function    C_F_PROCPOINTER(CPTR, FPTR [, SHAPE]) intrinsic.          *|
06001 |*                                                                            *|
06002 |* Input parameters:                                                          *|
06003 |*      NONE                                                                  *|
06004 |*                                                                            *|
06005 |* Output parameters:                                                         *|
06006 |*      NONE                                                                  *|
06007 |*                                                                            *|
06008 |* Returns:                                                                   *|
06009 |*      NOTHING                                                               *|
06010 |*                                                                            *|
06011 \******************************************************************************/
06012 
06013 void    c_f_pointer_intrinsic(opnd_type     *result_opnd,
06014                       expr_arg_type *res_exp_desc,
06015                       int           *spec_idx)
06016 {
06017    int            attr_idx = NULL_IDX;
06018    int      unused1 = NULL_IDX;
06019    int      unused2 = NULL_IDX;
06020 
06021    TRACE (Func_Entry, "c_f_pointer_intrinsic", NULL);
06022 
06023    int ir_idx = OPND_IDX((*result_opnd));
06024    boolean has_shape_arg = IR_LIST_CNT_R(ir_idx) == 3;
06025    int list_idx1 = IR_IDX_R(ir_idx);
06026    int list_idx2 = IL_NEXT_LIST_IDX(list_idx1);
06027    int list_idx3 =  has_shape_arg ? IL_NEXT_LIST_IDX(list_idx2) : 0;
06028    int info_idx1 = IL_ARG_DESC_IDX(list_idx1);
06029    int info_idx2 = IL_ARG_DESC_IDX(list_idx2);
06030    int info_idx3 = has_shape_arg ? IL_ARG_DESC_IDX(list_idx3) : 0;
06031    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ptr_8;
06032    ATP_EXTERNAL_INTRIN(*spec_idx) = TRUE;
06033 
06034    conform_check(0, 
06035                  ir_idx,
06036                  res_exp_desc,
06037                  spec_idx,
06038                  TRUE);
06039 
06040    res_exp_desc->rank = 0;
06041 
06042    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
06043    IR_RANK(ir_idx) = res_exp_desc->rank;
06044 
06045    res_exp_desc->type_idx = IR_TYPE_IDX(ir_idx);
06046    res_exp_desc->type = TYP_TYPE(IR_TYPE_IDX(ir_idx));
06047    res_exp_desc->linear_type = TYP_LINEAR(IR_TYPE_IDX(ir_idx));
06048 
06049    if (IL_FLD(list_idx2) == AT_Tbl_Idx ||
06050        (IL_FLD(list_idx2) == IR_Tbl_Idx &&
06051         (IR_OPR(IL_IDX(list_idx2)) == Whole_Subscript_Opr ||
06052          IR_OPR(IL_IDX(list_idx2)) == Whole_Substring_Opr ||
06053          IR_OPR(IL_IDX(list_idx2)) == Struct_Opr ||
06054          IR_OPR(IL_IDX(list_idx2)) == Dv_Deref_Opr ||
06055          IR_OPR(IL_IDX(list_idx2)) == Subscript_Opr ||
06056          IR_OPR(IL_IDX(list_idx2)) == Substring_Opr ||
06057          IR_OPR(IL_IDX(list_idx2)) == Section_Subscript_Opr))) {
06058       attr_idx = find_base_attr(&IL_OPND(list_idx2), &unused1, &unused2);
06059 
06060       if (ATP_INTRIN_ENUM(*spec_idx) == C_F_Pointer_Intrinsic &&
06061   (AT_OBJ_CLASS(attr_idx) != Data_Obj || !ATD_POINTER(attr_idx))) {
06062   PRINTMSG(arg_info_list[info_idx2].line, 700,  Error, 
06063      arg_info_list[info_idx2].col, AT_OBJ_NAME_PTR(*spec_idx));
06064       }
06065       else if (ATP_INTRIN_ENUM(*spec_idx) == C_F_Procpointer_Intrinsic) {
06066   /* This will need more work once we have procedure pointer vars */
06067       }
06068    }
06069 
06070    int shape_error = FALSE;
06071    int rank2 = arg_info_list[info_idx2].ed.rank;
06072    /* If fptr is array, "shape" argument must be present with number of
06073     * elements matching rank of fptr */
06074    if (rank2) {
06075      if ((!has_shape_arg) || list_idx3 == NULL_IDX ||
06076        IL_IDX(list_idx3) == NULL_IDX) {
06077        shape_error = TRUE;
06078      }
06079      else if (arg_info_list[info_idx3].ed.assumed_size) {
06080        /* Assume ok because no way to know length of assumed-size array */
06081      }
06082      else if (arg_info_list[info_idx3].ed.rank != 1 ||
06083          !compare_length(arg_info_list[info_idx3].ed.shape[0], rank2)) {
06084        shape_error = TRUE;
06085      }
06086    } else {
06087      shape_error = has_shape_arg ||
06088        (list_idx3 != NULL_IDX && IL_IDX(list_idx3) != NULL_IDX);
06089    }
06090    if (shape_error) {
06091      PRINTMSG(arg_info_list[info_idx2].line, 1698, Error,
06092        arg_info_list[info_idx2].col);
06093    }
06094 
06095    res_exp_desc->foldable = FALSE;
06096    res_exp_desc->will_fold_later = FALSE;
06097 
06098    TRACE (Func_Exit, "c_f_pointer_intrinsic", NULL);
06099 
06100 }  /* c_f_pointer_intrinsic */
06101 #endif /* KEY Bug 14150 */
06102 
06103 
06104 /******************************************************************************\
06105 |*                                                                            *|
06106 |* Description:                                                               *|
06107 |*      Function    FCD(I, J) intrinsic.                                      *|
06108 |*                                                                            *|
06109 |* Input parameters:                                                          *|
06110 |*      NONE                                                                  *|
06111 |*                                                                            *|
06112 |* Output parameters:                                                         *|
06113 |*      NONE                                                                  *|
06114 |*                                                                            *|
06115 |* Returns:                                                                   *|
06116 |*      NOTHING                                                               *|
06117 |*                                                                            *|
06118 \******************************************************************************/
06119 
06120 void    fcd_intrinsic(opnd_type     *result_opnd,
06121                       expr_arg_type *res_exp_desc,
06122                       int           *spec_idx)
06123 {
06124    int            ir_idx;
06125 
06126 
06127    TRACE (Func_Entry, "fcd_intrinsic", NULL);
06128 
06129    ir_idx = OPND_IDX((*result_opnd));
06130    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = CRI_Ch_Ptr_8;
06131 
06132    conform_check(0, 
06133                  ir_idx,
06134                  res_exp_desc,
06135                  spec_idx,
06136                  FALSE);
06137 
06138    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
06139    IR_RANK(ir_idx) = res_exp_desc->rank;
06140    IR_OPR(ir_idx) = Fcd_Opr;
06141 
06142    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
06143    IR_OPND_R(ir_idx) = null_opnd;
06144 
06145    /* must reset foldable and will_fold_later because there is no */
06146    /* folder for this intrinsic in constructors.                  */
06147 
06148    res_exp_desc->foldable = FALSE;
06149    res_exp_desc->will_fold_later = FALSE;
06150 
06151    TRACE (Func_Exit, "fcd_intrinsic", NULL);
06152 
06153 }  /* fcd_intrinsic */
06154 
06155 
06156 
06157 
06158 /******************************************************************************\
06159 |*                                                                            *|
06160 |* Description:                                                               *|
06161 |*      Function    FETCH_AND_ADD(I, J) intrinsic.                            *|
06162 |*      Function    FETCH_AND_AND(I, J) intrinsic.                            *|
06163 |*      Function    FETCH_AND_NAND(I, J) intrinsic.                           *|
06164 |*      Function    FETCH_AND_OR(I, J) intrinsic.                             *|
06165 |*      Function    FETCH_AND_SUB(I, J) intrinsic.                            *|
06166 |*      Function    FETCH_AND_XOR(I, J) intrinsic.                            *|
06167 |*      Function    ADD_AND_FETCH(I, J) intrinsic.                            *|
06168 |*      Function    AND_AND_FETCH(I, J) intrinsic.                            *|
06169 |*      Function    NAND_AND_FETCH(I, J) intrinsic.                           *|
06170 |*      Function    OR_AND_FETCH(I, J) intrinsic.                             *|
06171 |*      Function    SUB_AND_FETCH(I, J) intrinsic.                            *|
06172 |*      Function    XOR_AND_FETCH(I, J) intrinsic.                            *|
06173 |*      Function    LOCK_TEST_AND_SET(I, J) intrinsic.                        *|
06174 |*                                                                            *|
06175 |* Input parameters:                                                          *|
06176 |*      NONE                                                                  *|
06177 |*                                                                            *|
06178 |* Output parameters:                                                         *|
06179 |*      NONE                                                                  *|
06180 |*                                                                            *|
06181 |* Returns:                                                                   *|
06182 |*      NOTHING                                                               *|
06183 |*                                                                            *|
06184 \******************************************************************************/
06185 void    fetch_and_add_intrinsic(opnd_type     *result_opnd,
06186                                 expr_arg_type *res_exp_desc,
06187                                 int           *spec_idx) 
06188 {
06189    int            ir_idx;
06190    int            list_idx1;
06191    int            info_idx1;
06192 
06193 
06194    TRACE (Func_Entry, "fetch_and_add_intrinsic", NULL);
06195 
06196    ir_idx = OPND_IDX((*result_opnd));
06197 
06198    list_idx1 = IR_IDX_R(ir_idx);
06199    info_idx1 = IL_ARG_DESC_IDX(list_idx1);
06200 
06201    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = arg_info_list[info_idx1].ed.type_idx;
06202 
06203    conform_check(0, 
06204                  ir_idx,
06205                  res_exp_desc,
06206                  spec_idx,
06207                  FALSE);
06208 
06209    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
06210    IR_RANK(ir_idx) = res_exp_desc->rank;
06211 
06212    io_item_must_flatten = TRUE;
06213 
06214    if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Add_Intrinsic) {
06215       IR_OPR(ir_idx) = Fetch_And_Add_Opr;
06216    }
06217    else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_And_Intrinsic) {
06218       IR_OPR(ir_idx) = Fetch_And_And_Opr;
06219    }
06220    else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Nand_Intrinsic) {
06221       IR_OPR(ir_idx) = Fetch_And_Nand_Opr;
06222    }
06223    else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Or_Intrinsic) {
06224       IR_OPR(ir_idx) = Fetch_And_Or_Opr;
06225    }
06226    else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Xor_Intrinsic) {
06227       IR_OPR(ir_idx) = Fetch_And_Xor_Opr;
06228    }
06229    else if (ATP_INTRIN_ENUM(*spec_idx) == Fetch_And_Sub_Intrinsic) {
06230       IR_OPR(ir_idx) = Fetch_And_Sub_Opr;
06231    }
06232    else if (ATP_INTRIN_ENUM(*spec_idx) == Add_And_Fetch_Intrinsic) {
06233       IR_OPR(ir_idx) = Add_And_Fetch_Opr;
06234    }
06235    else if (ATP_INTRIN_ENUM(*spec_idx) == And_And_Fetch_Intrinsic) {
06236       IR_OPR(ir_idx) = And_And_Fetch_Opr;
06237    }
06238    else if (ATP_INTRIN_ENUM(*spec_idx) == Nand_And_Fetch_Intrinsic) {
06239       IR_OPR(ir_idx) = Nand_And_Fetch_Opr;
06240    }
06241    else if (ATP_INTRIN_ENUM(*spec_idx) == Or_And_Fetch_Intrinsic) {
06242       IR_OPR(ir_idx) = Or_And_Fetch_Opr;
06243    }
06244    else if (ATP_INTRIN_ENUM(*spec_idx) == Sub_And_Fetch_Intrinsic) {
06245       IR_OPR(ir_idx) = Sub_And_Fetch_Opr;
06246    }
06247    else if (ATP_INTRIN_ENUM(*spec_idx) == Xor_And_Fetch_Intrinsic) {
06248       IR_OPR(ir_idx) = Xor_And_Fetch_Opr;
06249    }
06250    else if (ATP_INTRIN_ENUM(*spec_idx) == Lock_Test_And_Set_Intrinsic) {
06251       IR_OPR(ir_idx) = Lock_Test_And_Set_Opr;
06252    }
06253 
06254    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
06255    IR_OPND_R(ir_idx) = null_opnd;
06256 
06257    /* must reset foldable and will_fold_later because there is no */
06258    /* folder for this intrinsic in constructors.                  */
06259 
06260    res_exp_desc->foldable = FALSE;
06261    res_exp_desc->will_fold_later = FALSE;
06262 
06263    TRACE (Func_Exit, "fetch_and_add_intrinsic", NULL);
06264 
06265 }  /* fetch_and_add_intrinsic */
06266 
06267 
06268 
06269 /******************************************************************************\
06270 |*                                                                            *|
06271 |* Description:                                                               *|
06272 |*      Function    NUMARG() intrinsic.                                       *|
06273 |*                                                                            *|
06274 |* Input parameters:                                                          *|
06275 |*      NONE                                                                  *|
06276 |*                                                                            *|
06277 |* Output parameters:                                                         *|
06278 |*      NONE                                                                  *|
06279 |*                                                                            *|
06280 |* Returns:                                                                   *|
06281 |*      NOTHING                                                               *|
06282 |*                                                                            *|
06283 \******************************************************************************/
06284 
06285 void    numarg_intrinsic(opnd_type     *result_opnd,
06286                          expr_arg_type *res_exp_desc,
06287                          int           *spec_idx)
06288 {
06289    int            ir_idx;
06290 
06291 
06292    TRACE (Func_Entry, "numarg_intrinsic", NULL);
06293 
06294    ir_idx = OPND_IDX((*result_opnd));
06295    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
06296 
06297    conform_check(0, 
06298                  ir_idx,
06299                  res_exp_desc,
06300                  spec_idx,
06301                  FALSE);
06302 
06303    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
06304    IR_RANK(ir_idx) = res_exp_desc->rank;
06305    IR_OPR(ir_idx) = Numarg_Opr;
06306 
06307    COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(ir_idx));
06308    IR_OPND_R(ir_idx) = null_opnd;
06309 
06310    /* must reset foldable and will_fold_later because there is no */
06311    /* folder for this intrinsic in constructors.                  */
06312 
06313    res_exp_desc->foldable = FALSE;
06314    res_exp_desc->will_fold_later = FALSE;
06315 
06316    TRACE (Func_Exit, "numarg_intrinsic", NULL);
06317 
06318 }  /* numarg_intrinsic */
06319 
06320 
06321 
06322 /******************************************************************************\
06323 |*                                                                            *|
06324 |* Description:                                                               *|
06325 |*      Function    READ@SM() intrinsic.                                      *|
06326 |*                                                                            *|
06327 |* Input parameters:                                                          *|
06328 |*      NONE                                                                  *|
06329 |*                                                                            *|
06330 |* Output parameters:                                                         *|
06331 |*      NONE                                                                  *|
06332 |*                                                                            *|
06333 |* Returns:                                                                   *|
06334 |*      NOTHING                                                               *|
06335 |*                                                                            *|
06336 \******************************************************************************/
06337 
06338 void    readsm_intrinsic(opnd_type     *result_opnd,
06339                          expr_arg_type *res_exp_desc,
06340                          int           *spec_idx)
06341 {
06342    int            ir_idx;
06343 
06344    TRACE (Func_Entry, "readsm_intrinsic", NULL);
06345 
06346    ir_idx = OPND_IDX((*result_opnd));
06347    ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx)) = INTEGER_DEFAULT_TYPE;
06348 
06349    conform_check(0, 
06350                  ir_idx,
06351                  res_exp_desc,
06352                  spec_idx,
06353                  FALSE);
06354 
06355    IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(ATP_RSLT_IDX(*spec_idx));
06356    IR_RANK(ir_idx) = res_exp_desc->rank;
06357    IR_OPR(ir_idx) = Readsm_Opr;
06358 
06359    IR_OPND_L(ir_idx) = null_opnd;
06360    IR_OPND_R(ir_idx) = null_opnd;
06361 
06362    /* must reset foldable and will_fold_later because there is no */
06363    /* folder for this intrinsic in constructors.                  */
06364 
06365    res_exp_desc->foldable = FALSE;
06366    res_exp_desc->will_fold_later = FALSE;
06367 
06368    TRACE (Func_Exit, "readsm_intrinsic", NULL);
06369 
06370 }  /* readsm_intrinsic */
06371 
06372 
06373 
06374 /******************************************************************************\
06375 |*                                                                            *|
06376 |* Description:                                                               *|
06377 |*      Subroutine  MEMORY_BARRIER() intrinsic.                               *|
06378 |*                                                                            *|
06379 |* Input parameters:                                                          *|
06380 |*      NONE                                                                  *|
06381 |*                                                                            *|
06382 |* Output parameters:                                                         *|
06383 |*      NONE                                                                  *|
06384 |*                                                                            *|
06385 |* Returns:                                                                   *|
06386 |*      NOTHING                                                               *|
06387 |*                                                                            *|
06388 \******************************************************************************/
06389 
06390 void    memory_barrier_intrinsic(opnd_type     *result_opnd,
06391                                  expr_arg_type *res_exp_desc,
06392                                  int           *spec_idx)
06393 {
06394    int            ir_idx;
06395 
06396 
06397    TRACE (Func_Entry, "memory_barrier_intrinsic", NULL);
06398 
06399    ir_idx = OPND_IDX((*result_opnd));
06400 
06401    conform_check(0,
06402                  ir_idx,
06403                  res_exp_desc,
06404                  spec_idx,
06405                  FALSE);
06406 
06407    IR_RANK(ir_idx) = res_exp_desc->rank;
06408    IR_OPR(ir_idx) = Memory_Barrier_Opr;
06409 
06410    IR_OPND_L(ir_idx) = null_opnd;
06411    IR_OPND_R(ir_idx) = null_opnd;
06412 
06413    /* must reset foldable and will_fold_later because there is no */
06414    /* folder for this intrinsic in constructors.                  */
06415 
06416    res_exp_desc->foldable = FALSE;
06417    res_exp_desc->will_fold_later = FALSE;
06418 
06419    TRACE (Func_Exit, "memory_barrier_intrinsic", NULL);
06420 
06421 }  /* memory_barrier_intrinsic */
06422 
06423 
06424 
06425 /******************************************************************************\
06426 |*                                                                            *|
06427 |* Description:                                                               *|
06428 |*      Subroutine  REMOTE_WRITE_BARRIER() intrinsic.                         *|
06429 |*                                                                            *|
06430 |* Input parameters:                                                          *|
06431 |*      NONE                                                                  *|
06432 |*                                                                            *|
06433 |* Output parameters:                                                         *|
06434 |*      NONE                                                                  *|
06435 |*                                                                            *|
06436 |* Returns:                                                                   *|
06437 |*      NOTHING                                                               *|
06438 |*                                                                            *|
06439 \******************************************************************************/
06440 
06441 void    remote_write_barrier_intrinsic(opnd_type     *result_opnd,
06442                                        expr_arg_type *res_exp_desc,
06443                                        int           *spec_idx) 
06444 {
06445    int            ir_idx;
06446 
06447 
06448    TRACE (Func_Entry, "remote_write_barrier_intrinsic", NULL);
06449 
06450    ir_idx = OPND_IDX((*result_opnd));
06451 
06452    conform_check(0,
06453                  ir_idx,
06454                  res_exp_desc,
06455                  spec_idx,
06456                  FALSE);
06457 
06458    IR_RANK(ir_idx) = res_exp_desc->rank;
06459    IR_OPR(ir_idx) = Remote_Write_Barrier_Opr;
06460 
06461    IR_OPND_L(ir_idx) = null_opnd;
06462    IR_OPND_R(ir_idx) = null_opnd;
06463 
06464    /* must reset foldable and will_fold_later because there is no */
06465    /* folder for this intrinsic in constructors.                  */
06466 
06467    res_exp_desc->foldable = FALSE;
06468    res_exp_desc->will_fold_later = FALSE;
06469 
06470    TRACE (Func_Exit, "remote_write_barrier_intrinsic", NULL);
06471 
06472 }  /* remote_write_barrier_intrinsic */
06473 
06474 /******************************************************************************\
06475 |*                                                                            *|
06476 |* Description:                                                               *|
06477 |*      Subroutine  WRITE_MEMORY_BARRIER() intrinsic.                         *|
06478 |*                                                                            *|
06479 |* Input parameters:                                                          *|
06480 |*      NONE                                                                  *|
06481 |*                                                                            *|
06482 |* Output parameters:                                                         *|
06483 |*      NONE                                                                  *|
06484 |*                                                                            *|
06485 |* Returns:                                                                   *|
06486 |*      NOTHING                                                               *|
06487 |*                                                                            *|
06488 \******************************************************************************/
06489 
06490 void    write_memory_barrier_intrinsic(opnd_type     *result_opnd,
06491                                        expr_arg_type *res_exp_desc,
06492                                        int           *spec_idx)
06493 {
06494    int            ir_idx;
06495 
06496 
06497    TRACE (Func_Entry, "write_memory_barrier_intrinsic", NULL);
06498 
06499    ir_idx = OPND_IDX((*result_opnd));
06500 
06501    conform_check(0,
06502                  ir_idx,
06503                  res_exp_desc,
06504                  spec_idx,
06505                  FALSE);
06506 
06507    IR_RANK(ir_idx) = res_exp_desc->rank;
06508    IR_OPR(ir_idx) = Write_Memory_Barrier_Opr;
06509 
06510    IR_OPND_L(ir_idx) = null_opnd;
06511    IR_OPND_R(ir_idx) = null_opnd;
06512 
06513    /* must reset foldable and will_fold_later because there is no */
06514    /* folder for this intrinsic in constructors.                  */
06515 
06516    res_exp_desc->foldable = FALSE;
06517    res_exp_desc->will_fold_later = FALSE;
06518 
06519    TRACE (Func_Exit, "write_memory_barrier_intrinsic", NULL);
06520 
06521 }  /* write_memory_barrier_intrinsic */
06522 
06523 /******************************************************************************\
06524 |*                                                                            *|
06525 |* Description:                                                               *|
06526 |*      Subroutine  SYNCHRONIZE() intrinsic.                                  *|
06527 |*                                                                            *|
06528 |* Input parameters:                                                          *|
06529 |*      NONE                                                                  *|
06530 |*                                                                            *|
06531 |* Output parameters:                                                         *|
06532 |*      NONE                                                                  *|
06533 |*                                                                            *|
06534 |* Returns:                                                                   *|
06535 |*      NOTHING                                                               *|
06536 |*                                                                            *|
06537 \******************************************************************************/
06538 void    synchronize_intrinsic(opnd_type     *result_opnd,
06539                               expr_arg_type *res_exp_desc,
06540                               int           *spec_idx) 
06541 {
06542    int            ir_idx;
06543 
06544 
06545    TRACE (Func_Entry, "synchronize_intrinsic", NULL);
06546 
06547    ir_idx = OPND_IDX((*result_opnd));
06548 
06549    conform_check(0, 
06550                  ir_idx,
06551                  res_exp_desc,
06552                  spec_idx,
06553                  FALSE);
06554 
06555    IR_TYPE_IDX(ir_idx) = TYPELESS_DEFAULT_TYPE;
06556    IR_RANK(ir_idx) = res_exp_desc->rank;
06557    IR_OPR(ir_idx) = Synchronize_Opr;
06558 
06559    IR_OPND_L(ir_idx) =