home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / intrin.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  69KB  |  1,973 lines
  1. /* intrin.c -- Recognize references to intrinsics
  2.    Copyright (C) 1995 Free Software Foundation, Inc.
  3.    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
  4.  
  5. This file is part of GNU Fortran.
  6.  
  7. GNU Fortran is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2, or (at your option)
  10. any later version.
  11.  
  12. GNU Fortran is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. GNU General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with GNU Fortran; see the file COPYING.  If not, write to
  19. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. */
  22.  
  23. #include "proj.h"
  24. #include <ctype.h>
  25. #include "intrin.h"
  26. #include "info.h"
  27. #include "src.h"
  28. #include "target.h"
  29. #include "top.h"
  30.  
  31. struct _ffeintrin_name_
  32.   {
  33.     char *name_uc;
  34.     char *name_lc;
  35.     char *name_ic;
  36.     ffeintrinGen generic;
  37.     ffeintrinSpec specific;
  38.   };
  39.  
  40. struct _ffeintrin_gen_
  41.   {
  42.     char *name;            /* Name as seen in program. */
  43.     ffeintrinSpec specs[14];
  44.   };
  45.  
  46. struct _ffeintrin_spec_
  47.   {
  48.     char *name;            /* Uppercase name as seen in source code,
  49.                    lowercase if no source name, "none" if no
  50.                    name at all (NONE case). */
  51.     bool is_actualarg;        /* Ok to pass as actual arg if -pedantic. */
  52.     ffeintrinFamily family;
  53.     ffeintrinImp implementation;
  54.   };
  55.  
  56. struct _ffeintrin_imp_
  57.   {
  58.     char *name;            /* Name of implementation. */
  59. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  60.     ffecomGfrt gfrt;        /* gfrt index in library. */
  61. #endif
  62.     ffeinfoBasictype basictype;
  63.     ffeinfoKindtype kindtype;
  64.     ffetargetCharacterSize size;
  65.     ffebad (*check) (ffebld arglist);
  66.   };
  67.  
  68. static ffebad ffeintrin_check_1_ (ffebld arglist, ffebld *xarg1);
  69. static ffebad ffeintrin_check_1or2_ (ffebld arglist, ffebld *xarg1,
  70.                      ffebld *xarg2);
  71. static ffebad ffeintrin_check_2_ (ffebld arglist, ffebld *xarg1,
  72.                   ffebld *xarg2);
  73. static ffebad ffeintrin_check_3_ (ffebld arglist, ffebld *xarg1,
  74.                   ffebld *xarg2, ffebld *xarg3);
  75. static ffebad ffeintrin_check_5_ (ffebld arglist, ffebld *xarg1,
  76.                   ffebld *xarg2, ffebld *xarg3,
  77.                   ffebld *xarg4, ffebld *xarg5);
  78. static bool ffeintrin_check_any_ (ffebld arglist);
  79. static ffebad ffeintrin_check_char_1_ (ffebld arglist);
  80. static ffebad ffeintrin_check_char_2_ (ffebld arglist);
  81. static ffebad ffeintrin_check_cmplx_1_ (ffebld arglist);
  82. static ffebad ffeintrin_check_cmplx_1or2_ (ffebld arglist);
  83. static ffebad ffeintrin_check_dcmplx_1_ (ffebld arglist);
  84. static ffebad ffeintrin_check_dcmplx_1or2_ (ffebld arglist);
  85. static ffebad ffeintrin_check_int_1_ (ffebld arglist);
  86. static ffebad ffeintrin_check_int_1or2_ (ffebld arglist);
  87. static ffebad ffeintrin_check_int_2_ (ffebld arglist);
  88. static ffebad ffeintrin_check_int_2p_ (ffebld arglist);
  89. static ffebad ffeintrin_check_int_3_ (ffebld arglist);
  90. static ffebad ffeintrin_check_loc_ (ffebld arglist);
  91. static ffebad ffeintrin_check_log_1_ (ffebld arglist);
  92. #if 0
  93. static ffebad ffeintrin_check_log_1or2_ (ffebld arglist);
  94. #endif
  95. static ffebad ffeintrin_check_log_2_ (ffebld arglist);
  96. #if 0
  97. static ffebad ffeintrin_check_log_2p_ (ffebld arglist);
  98. #endif
  99. static ffebad ffeintrin_check_mvbits_ (ffebld arglist);
  100. static ffebad ffeintrin_check_procedure_ (ffeintrinImp imp, ffebldOp op);
  101. static ffebad ffeintrin_check_real_1_ (ffebld arglist);
  102. static ffebad ffeintrin_check_real_1or2_ (ffebld arglist);
  103. static ffebad ffeintrin_check_real_2_ (ffebld arglist);
  104. static ffebad ffeintrin_check_real_2p_ (ffebld arglist);
  105. static ffebad ffeintrin_check_realdbl_1_ (ffebld arglist);
  106. static ffebad ffeintrin_check_realdbl_1or2_ (ffebld arglist);
  107. static ffebad ffeintrin_check_realdbl_2_ (ffebld arglist);
  108. static ffebad ffeintrin_check_realdbl_2p_ (ffebld arglist);
  109. static ffebad ffeintrin_check_void_ (ffebld arglist);
  110. static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
  111.  
  112. static struct _ffeintrin_name_ ffeintrin_names_[]
  113. =
  114. {                /* Alpha order. */
  115.   {"ABS", "abs", "Abs", FFEINTRIN_genABS, FFEINTRIN_specABS,},
  116.   {"ACHAR", "achar", "AChar", FFEINTRIN_genACHAR, FFEINTRIN_specNONE,},    /* F90, F2C */
  117.   {"ACOS", "acos", "ACos", FFEINTRIN_genACOS, FFEINTRIN_specACOS,},
  118.   {"ACOSD", "acosd", "ACosD", FFEINTRIN_genACOSD, FFEINTRIN_specACOSD,},    /* VXT */
  119. {"ADJUSTL", "adjustl", "AdjustL", FFEINTRIN_genADJUSTL, FFEINTRIN_specNONE,},    /* F90 */
  120. {"ADJUSTR", "adjustr", "AdjustR", FFEINTRIN_genADJUSTR, FFEINTRIN_specNONE,},    /* F90 */
  121.   {"AIMAG", "aimag", "AImag", FFEINTRIN_genAIMAG, FFEINTRIN_specAIMAG,},
  122.   {"AIMAX0", "aimax0", "AIMax0", FFEINTRIN_genNONE, FFEINTRIN_specAIMAX0,},    /* VXT */
  123.   {"AIMIN0", "aimin0", "AIMin0", FFEINTRIN_genNONE, FFEINTRIN_specAIMIN0,},    /* VXT */
  124.   {"AINT", "aint", "AInt", FFEINTRIN_genAINT, FFEINTRIN_specAINT,},
  125.   {"AJMAX0", "ajmax0", "AJMax0", FFEINTRIN_genNONE, FFEINTRIN_specAJMAX0,},    /* VXT */
  126.   {"AJMIN0", "ajmin0", "AJMin0", FFEINTRIN_genNONE, FFEINTRIN_specAJMIN0,},    /* VXT */
  127.   {"ALL", "all", "All", FFEINTRIN_genALL, FFEINTRIN_specNONE,},    /* F90 */
  128.   {"ALLOCATED", "allocated", "Allocated", FFEINTRIN_genALLOCATED, FFEINTRIN_specNONE,},    /* F90 */
  129.   {"ALOG", "alog", "ALog", FFEINTRIN_genNONE, FFEINTRIN_specALOG,},
  130.   {"ALOG10", "alog10", "ALog10", FFEINTRIN_genNONE, FFEINTRIN_specALOG10,},
  131.   {"AMAX0", "amax0", "AMax0", FFEINTRIN_genAMAX0, FFEINTRIN_specAMAX0,},
  132.   {"AMAX1", "amax1", "AMax1", FFEINTRIN_genNONE, FFEINTRIN_specAMAX1,},
  133.   {"AMIN0", "amin0", "AMin0", FFEINTRIN_genAMIN0, FFEINTRIN_specAMIN0,},
  134.   {"AMIN1", "amin1", "AMin1", FFEINTRIN_genNONE, FFEINTRIN_specAMIN1,},
  135.   {"AMOD", "amod", "AMod", FFEINTRIN_genNONE, FFEINTRIN_specAMOD,},
  136.   {"AND", "and", "And", FFEINTRIN_genAND, FFEINTRIN_specNONE,},    /* F2C */
  137.   {"ANINT", "anint", "ANInt", FFEINTRIN_genANINT, FFEINTRIN_specANINT,},
  138.   {"ANY", "any", "Any", FFEINTRIN_genANY, FFEINTRIN_specNONE,},    /* F90 */
  139.   {"ASIN", "asin", "ASin", FFEINTRIN_genASIN, FFEINTRIN_specASIN,},
  140.   {"ASIND", "asind", "ASinD", FFEINTRIN_genASIND, FFEINTRIN_specASIND,},    /* VXT */
  141.   {"ASSOCIATED", "associated", "Associated", FFEINTRIN_genASSOCIATED, FFEINTRIN_specNONE,},    /* F90 */
  142.   {"ATAN", "atan", "ATan", FFEINTRIN_genATAN, FFEINTRIN_specATAN,},
  143.   {"ATAN2", "atan2", "ATan2", FFEINTRIN_genATAN2, FFEINTRIN_specATAN2,},
  144.   {"ATAN2D", "atan2d", "ATan2D", FFEINTRIN_genATAN2D, FFEINTRIN_specATAN2D,},    /* VXT */
  145.   {"ATAND", "atand", "ATanD", FFEINTRIN_genATAND, FFEINTRIN_specATAND,},    /* VXT */
  146.   {"BITEST", "bitest", "BITest", FFEINTRIN_genNONE, FFEINTRIN_specBITEST,},    /* VXT */
  147.   {"BIT_SIZE", "bit_size", "Bit_Size", FFEINTRIN_genBIT_SIZE, FFEINTRIN_specNONE,},    /* F90 */
  148.   {"BJTEST", "bjtest", "BJTest", FFEINTRIN_genNONE, FFEINTRIN_specBJTEST,},    /* VXT */
  149.   {"BTEST", "btest", "BTest", FFEINTRIN_genBTEST, FFEINTRIN_specNONE,},    /* F90, VXT */
  150.   {"CABS", "cabs", "CAbs", FFEINTRIN_genNONE, FFEINTRIN_specCABS,},
  151.   {"CCOS", "ccos", "CCos", FFEINTRIN_genNONE, FFEINTRIN_specCCOS,},
  152.   {"CDABS", "cdabs", "CDAbs", FFEINTRIN_genNONE, FFEINTRIN_specCDABS,},    /* VXT */
  153.   {"CDCOS", "cdcos", "CDCos", FFEINTRIN_genNONE, FFEINTRIN_specCDCOS,},    /* VXT */
  154.   {"CDEXP", "cdexp", "CDExp", FFEINTRIN_genNONE, FFEINTRIN_specCDEXP,},    /* VXT */
  155.   {"CDLOG", "cdlog", "CDLog", FFEINTRIN_genNONE, FFEINTRIN_specCDLOG,},    /* VXT */
  156.   {"CDSIN", "cdsin", "CDSin", FFEINTRIN_genNONE, FFEINTRIN_specCDSIN,},    /* VXT */
  157.   {"CDSQRT", "cdsqrt", "CDSqRt", FFEINTRIN_genNONE, FFEINTRIN_specCDSQRT,},    /* VXT */
  158. {"CEILING", "ceiling", "Ceiling", FFEINTRIN_genCEILING, FFEINTRIN_specNONE,},    /* F90 */
  159.   {"CEXP", "cexp", "CExp", FFEINTRIN_genNONE, FFEINTRIN_specCEXP,},
  160.   {"CHAR", "char", "Char", FFEINTRIN_genCHAR, FFEINTRIN_specCHAR,},
  161.   {"CLOG", "clog", "CLog", FFEINTRIN_genNONE, FFEINTRIN_specCLOG,},
  162.   {"CMPLX", "cmplx", "Cmplx", FFEINTRIN_genCMPLX, FFEINTRIN_specNONE,},
  163.   {"CONJG", "conjg", "Conjg", FFEINTRIN_genCONJG, FFEINTRIN_specCONJG,},
  164.   {"COS", "cos", "Cos", FFEINTRIN_genCOS, FFEINTRIN_specCOS,},
  165.   {"COSD", "cosd", "CosD", FFEINTRIN_genCOSD, FFEINTRIN_specCOSD,},    /* VXT */
  166.   {"COSH", "cosh", "CosH", FFEINTRIN_genCOSH, FFEINTRIN_specCOSH,},
  167.   {"COUNT", "count", "Count", FFEINTRIN_genCOUNT, FFEINTRIN_specNONE,},    /* F90 */
  168.   {"CSHIFT", "cshift", "CShift", FFEINTRIN_genCSHIFT, FFEINTRIN_specNONE,},    /* F90 */
  169.   {"CSIN", "csin", "CSin", FFEINTRIN_genNONE, FFEINTRIN_specCSIN,},
  170.   {"CSQRT", "csqrt", "CSqRt", FFEINTRIN_genNONE, FFEINTRIN_specCSQRT,},
  171.   {"DABS", "dabs", "DAbs", FFEINTRIN_genNONE, FFEINTRIN_specDABS,},
  172.   {"DACOS", "dacos", "DACos", FFEINTRIN_genNONE, FFEINTRIN_specDACOS,},
  173.   {"DACOSD", "dacosd", "DACosD", FFEINTRIN_genNONE, FFEINTRIN_specDACOSD,},    /* VXT */
  174.   {"DASIN", "dasin", "DASin", FFEINTRIN_genNONE, FFEINTRIN_specDASIN,},
  175.   {"DASIND", "dasind", "DASinD", FFEINTRIN_genNONE, FFEINTRIN_specDASIND,},    /* VXT */
  176.   {"DATAN", "datan", "DATan", FFEINTRIN_genNONE, FFEINTRIN_specDATAN,},
  177.   {"DATAN2", "datan2", "DATan2", FFEINTRIN_genNONE, FFEINTRIN_specDATAN2,},
  178. {"DATAN2D", "datan2d", "DATan2D", FFEINTRIN_genNONE, FFEINTRIN_specDATAN2D,},    /* VXT */
  179.   {"DATAND", "datand", "DATanD", FFEINTRIN_genNONE, FFEINTRIN_specDATAND,},    /* VXT */
  180.   {"DATE_AND_TIME", "date_and_time", "Date_and_Time", FFEINTRIN_genNONE, FFEINTRIN_specDATE_AND_TIME,},    /* F90 */
  181.   {"DBLE", "dble", "Dble", FFEINTRIN_genDBLE, FFEINTRIN_specDBLE,},
  182.   {"DBLEQ", "dbleq", "DbleQ", FFEINTRIN_genNONE, FFEINTRIN_specDBLEQ,},    /* VXT */
  183.   {"DCMPLX", "dcmplx", "DCmplx", FFEINTRIN_genDCMPLX, FFEINTRIN_specNONE,},    /* F2C, VXT */
  184.   {"DCONJG", "dconjg", "DConjg", FFEINTRIN_genNONE, FFEINTRIN_specDCONJG,},    /* F2C, VXT */
  185.   {"DCOS", "dcos", "DCos", FFEINTRIN_genNONE, FFEINTRIN_specDCOS,},
  186.   {"DCOSD", "dcosd", "DCosD", FFEINTRIN_genNONE, FFEINTRIN_specDCOSD,},    /* VXT */
  187.   {"DCOSH", "dcosh", "DCosH", FFEINTRIN_genNONE, FFEINTRIN_specDCOSH,},
  188.   {"DDIM", "ddim", "DDim", FFEINTRIN_genNONE, FFEINTRIN_specDDIM,},
  189.   {"DEXP", "dexp", "DExp", FFEINTRIN_genNONE, FFEINTRIN_specDEXP,},
  190.   {"DFLOAT", "dfloat", "DFloat", FFEINTRIN_genDFLOAT, FFEINTRIN_specNONE,},    /* F2C, VXT */
  191.   {"DFLOTI", "dfloti", "DFlotI", FFEINTRIN_genNONE, FFEINTRIN_specDFLOTI,},    /* VXT */
  192.   {"DFLOTJ", "dflotj", "DFlotJ", FFEINTRIN_genNONE, FFEINTRIN_specDFLOTJ,},    /* VXT */
  193.   {"DIGITS", "digits", "Digits", FFEINTRIN_genDIGITS, FFEINTRIN_specNONE,},    /* F90 */
  194.   {"DIM", "dim", "DiM", FFEINTRIN_genDIM, FFEINTRIN_specDIM,},
  195.   {"DIMAG", "dimag", "DImag", FFEINTRIN_genNONE, FFEINTRIN_specDIMAG,},    /* VXT */
  196.   {"DINT", "dint", "DInt", FFEINTRIN_genNONE, FFEINTRIN_specDINT,},
  197.   {"DLOG", "dlog", "DLog", FFEINTRIN_genNONE, FFEINTRIN_specDLOG,},
  198.   {"DLOG10", "dlog10", "DLog10", FFEINTRIN_genNONE, FFEINTRIN_specDLOG10,},
  199.   {"DMAX1", "dmax1", "DMax1", FFEINTRIN_genNONE, FFEINTRIN_specDMAX1,},
  200.   {"DMIN1", "dmin1", "DMin1", FFEINTRIN_genNONE, FFEINTRIN_specDMIN1,},
  201.   {"DMOD", "dmod", "DMod", FFEINTRIN_genNONE, FFEINTRIN_specDMOD,},
  202.   {"DNINT", "dnint", "DNInt", FFEINTRIN_genNONE, FFEINTRIN_specDNINT,},
  203.   {"DOT_PRODUCT", "dot_product", "Dot_Product", FFEINTRIN_genDOT_PRODUCT, FFEINTRIN_specNONE,},    /* F90 */
  204.   {"DPROD", "dprod", "DProd", FFEINTRIN_genDPROD, FFEINTRIN_specDPROD,},
  205.   {"DREAL", "dreal", "DReal", FFEINTRIN_genNONE, FFEINTRIN_specDREAL,},    /* VXT */
  206.   {"DSIGN", "dsign", "DSign", FFEINTRIN_genNONE, FFEINTRIN_specDSIGN,},
  207.   {"DSIN", "dsin", "DSin", FFEINTRIN_genNONE, FFEINTRIN_specDSIN,},
  208.   {"DSIND", "dsind", "DSinD", FFEINTRIN_genNONE, FFEINTRIN_specDSIND,},    /* VXT */
  209.   {"DSINH", "dsinh", "DSinH", FFEINTRIN_genNONE, FFEINTRIN_specDSINH,},
  210.   {"DSQRT", "dsqrt", "DSqRt", FFEINTRIN_genNONE, FFEINTRIN_specDSQRT,},
  211.   {"DTAN", "dtan", "DTan", FFEINTRIN_genNONE, FFEINTRIN_specDTAN,},
  212.   {"DTAND", "dtand", "DTanD", FFEINTRIN_genNONE, FFEINTRIN_specDTAND,},    /* VXT */
  213.   {"DTANH", "dtanh", "DTanH", FFEINTRIN_genNONE, FFEINTRIN_specDTANH,},
  214. {"EOSHIFT", "eoshift", "EOShift", FFEINTRIN_genEOSHIFT, FFEINTRIN_specNONE,},    /* F90 */
  215. {"EPSILON", "epsilon", "Epsilon", FFEINTRIN_genEPSILON, FFEINTRIN_specNONE,},    /* F90 */
  216.   {"EXP", "exp", "Exp", FFEINTRIN_genEXP, FFEINTRIN_specEXP,},
  217.   {"EXPONENT", "exponent", "Exponent", FFEINTRIN_genEXPONENT, FFEINTRIN_specNONE,},    /* F90 */
  218.   {"FLOAT", "float", "Float", FFEINTRIN_genFLOAT, FFEINTRIN_specFLOAT,},
  219.   {"FLOATI", "floati", "FloatI", FFEINTRIN_genNONE, FFEINTRIN_specFLOATI,},    /* VXT */
  220.   {"FLOATJ", "floatj", "FloatJ", FFEINTRIN_genNONE, FFEINTRIN_specFLOATJ,},    /* VXT */
  221.   {"FLOOR", "floor", "Floor", FFEINTRIN_genFLOOR, FFEINTRIN_specNONE,},    /* F90 */
  222.   {"FPABSP", "fpabsp", "FPAbsP", FFEINTRIN_genFPABSP, FFEINTRIN_specNONE,},    /* F2C */
  223.   {"FPEXPN", "fpexpn", "FPExpn", FFEINTRIN_genFPEXPN, FFEINTRIN_specNONE,},    /* F2C */
  224.   {"FPFRAC", "fpfrac", "FPFrac", FFEINTRIN_genFPFRAC, FFEINTRIN_specNONE,},    /* F2C */
  225.   {"FPMAKE", "fpmake", "FPMake", FFEINTRIN_genFPMAKE, FFEINTRIN_specNONE,},    /* F2C */
  226.   {"FPRRSP", "fprrsp", "FPRRSp", FFEINTRIN_genFPRRSP, FFEINTRIN_specNONE,},    /* F2C */
  227.   {"FPSCAL", "fpscal", "FPScal", FFEINTRIN_genFPSCAL, FFEINTRIN_specNONE,},    /* F2C */
  228.   {"FRACTION", "fraction", "Fraction", FFEINTRIN_genFRACTION, FFEINTRIN_specNONE,},    /* F90 */
  229.   {"HUGE", "huge", "Huge", FFEINTRIN_genHUGE, FFEINTRIN_specNONE,},    /* F90 */
  230.   {"IABS", "iabs", "IAbs", FFEINTRIN_genIABS, FFEINTRIN_specIABS,},
  231.   {"IACHAR", "iachar", "IAChar", FFEINTRIN_genIACHAR, FFEINTRIN_specNONE,},    /* F90, F2C */
  232.   {"IAND", "iand", "IAnd", FFEINTRIN_genIAND, FFEINTRIN_specNONE,},    /* F90, VXT */
  233.   {"IBCLR", "ibclr", "IBClr", FFEINTRIN_genIBCLR, FFEINTRIN_specNONE,},    /* F90, VXT */
  234.   {"IBITS", "ibits", "IBits", FFEINTRIN_genIBITS, FFEINTRIN_specNONE,},    /* F90, VXT */
  235.   {"IBSET", "ibset", "IBSet", FFEINTRIN_genIBSET, FFEINTRIN_specNONE,},    /* F90, VXT */
  236.   {"ICHAR", "ichar", "IChar", FFEINTRIN_genICHAR, FFEINTRIN_specICHAR,},
  237.   {"IDIM", "idim", "IDiM", FFEINTRIN_genIDIM, FFEINTRIN_specIDIM,},
  238.   {"IDINT", "idint", "IDInt", FFEINTRIN_genIDINT, FFEINTRIN_specIDINT,},
  239.   {"IDNINT", "idnint", "IDNInt", FFEINTRIN_genIDNINT, FFEINTRIN_specIDNINT,},
  240.   {"IEOR", "ieor", "IEOr", FFEINTRIN_genIEOR, FFEINTRIN_specNONE,},    /* F90, VXT */
  241.   {"IFIX", "ifix", "IFix", FFEINTRIN_genIFIX, FFEINTRIN_specIFIX,},
  242.   {"IIABS", "iiabs", "IIAbs", FFEINTRIN_genNONE, FFEINTRIN_specIIABS,},    /* VXT */
  243.   {"IIAND", "iiand", "IIAnd", FFEINTRIN_genNONE, FFEINTRIN_specIIAND,},    /* VXT */
  244.   {"IIBCLR", "iibclr", "IIBClr", FFEINTRIN_genNONE, FFEINTRIN_specIIBCLR,},    /* VXT */
  245.   {"IIBITS", "iibits", "IIBits", FFEINTRIN_genNONE, FFEINTRIN_specIIBITS,},    /* VXT */
  246.   {"IIBSET", "iibset", "IIBSet", FFEINTRIN_genNONE, FFEINTRIN_specIIBSET,},    /* VXT */
  247.   {"IIDIM", "iidim", "IIDiM", FFEINTRIN_genNONE, FFEINTRIN_specIIDIM,},    /* VXT */
  248.   {"IIDINT", "iidint", "IIDint", FFEINTRIN_genNONE, FFEINTRIN_specIIDINT,},    /* VXT */
  249.   {"IIDNNT", "iidnnt", "IIDNnt", FFEINTRIN_genNONE, FFEINTRIN_specIIDNNT,},    /* VXT */
  250.   {"IIEOR", "iieor", "IIEOr", FFEINTRIN_genNONE, FFEINTRIN_specIIEOR,},    /* VXT */
  251.   {"IIFIX", "iifix", "IIFix", FFEINTRIN_genNONE, FFEINTRIN_specIIFIX,},    /* VXT */
  252.   {"IINT", "iint", "IInt", FFEINTRIN_genNONE, FFEINTRIN_specIINT,},    /* VXT */
  253.   {"IIOR", "iior", "IIOr", FFEINTRIN_genNONE, FFEINTRIN_specIIOR,},    /* VXT */
  254.   {"IIQINT", "iiqint", "IIQint", FFEINTRIN_genNONE, FFEINTRIN_specIIQINT,},    /* VXT */
  255.   {"IIQNNT", "iiqnnt", "IIQNnt", FFEINTRIN_genNONE, FFEINTRIN_specIIQNNT,},    /* VXT */
  256.   {"IISHFT", "iishft", "IIShft", FFEINTRIN_genNONE, FFEINTRIN_specNONE,},    /* VXT */
  257. {"IISHFTC", "iishftc", "IIShftC", FFEINTRIN_genNONE, FFEINTRIN_specIISHFTC,},    /* VXT */
  258.   {"IISIGN", "iisign", "IISign", FFEINTRIN_genNONE, FFEINTRIN_specIISIGN,},    /* VXT */
  259.   {"IMAG", "imag", "Imag", FFEINTRIN_genIMAG, FFEINTRIN_spec_IMAG_C_F2C,},    /* F2C */
  260.   {"IMAX0", "imax0", "IMax0", FFEINTRIN_genNONE, FFEINTRIN_specIMAX0,},    /* VXT */
  261.   {"IMAX1", "imax1", "IMax1", FFEINTRIN_genNONE, FFEINTRIN_specIMAX1,},    /* VXT */
  262.   {"IMIN0", "imin0", "IMin0", FFEINTRIN_genNONE, FFEINTRIN_specIMIN0,},    /* VXT */
  263.   {"IMIN1", "imin1", "IMin1", FFEINTRIN_genNONE, FFEINTRIN_specIMIN1,},    /* VXT */
  264.   {"IMOD", "imod", "IMod", FFEINTRIN_genNONE, FFEINTRIN_specIMOD,},    /* VXT */
  265.   {"INDEX", "index", "Index", FFEINTRIN_genINDEX, FFEINTRIN_specINDEX,},
  266.   {"ININT", "inint", "INInt", FFEINTRIN_genNONE, FFEINTRIN_specININT,},    /* VXT */
  267.   {"INOT", "inot", "INot", FFEINTRIN_genNONE, FFEINTRIN_specINOT,},    /* VXT */
  268.   {"INT", "int", "Int", FFEINTRIN_genINT, FFEINTRIN_specINT,},
  269.   {"IOR", "ior", "IOr", FFEINTRIN_genIOR, FFEINTRIN_specNONE,},    /* F90, VXT */
  270.   {"ISHFT", "ishft", "IShft", FFEINTRIN_genISHFT, FFEINTRIN_specNONE,},    /* F90 */
  271.   {"ISHFTC", "ishftc", "IShftC", FFEINTRIN_genISHFTC, FFEINTRIN_specNONE,},    /* F90, VXT */
  272.   {"ISIGN", "isign", "ISign", FFEINTRIN_genNONE, FFEINTRIN_specISIGN,},
  273.   {"IZEXT", "izext", "IZExt", FFEINTRIN_genNONE, FFEINTRIN_specIZEXT,},    /* VXT */
  274.   {"JIABS", "jiabs", "JIAbs", FFEINTRIN_genNONE, FFEINTRIN_specJIABS,},    /* VXT */
  275.   {"JIAND", "jiand", "JIAnd", FFEINTRIN_genNONE, FFEINTRIN_specJIAND,},    /* VXT */
  276.   {"JIBCLR", "jibclr", "JIBClr", FFEINTRIN_genNONE, FFEINTRIN_specJIBCLR,},    /* VXT */
  277.   {"JIBITS", "jibits", "JIBits", FFEINTRIN_genNONE, FFEINTRIN_specJIBITS,},    /* VXT */
  278.   {"JIBSET", "jibset", "JIBSet", FFEINTRIN_genNONE, FFEINTRIN_specJIBSET,},    /* VXT */
  279.   {"JIDIM", "jidim", "JIDiM", FFEINTRIN_genNONE, FFEINTRIN_specJIDIM,},    /* VXT */
  280.   {"JIDINT", "jidint", "JIDint", FFEINTRIN_genNONE, FFEINTRIN_specJIDINT,},    /* VXT */
  281.   {"JIDNNT", "jidnnt", "JIDNnt", FFEINTRIN_genNONE, FFEINTRIN_specJIDNNT,},    /* VXT */
  282.   {"JIEOR", "jieor", "JIEOr", FFEINTRIN_genNONE, FFEINTRIN_specJIEOR,},    /* VXT */
  283.   {"JIFIX", "jifix", "JIFix", FFEINTRIN_genNONE, FFEINTRIN_specJIFIX,},    /* VXT */
  284.   {"JINT", "jint", "JInt", FFEINTRIN_genNONE, FFEINTRIN_specJINT,},    /* VXT */
  285.   {"JIOR", "jior", "JIOr", FFEINTRIN_genNONE, FFEINTRIN_specJIOR,},    /* VXT */
  286.   {"JIQINT", "jiqint", "JIQint", FFEINTRIN_genNONE, FFEINTRIN_specJIQINT,},    /* VXT */
  287.   {"JIQNNT", "jiqnnt", "JIQNnt", FFEINTRIN_genNONE, FFEINTRIN_specJIQNNT,},    /* VXT */
  288.   {"JISHFT", "jishft", "JIShft", FFEINTRIN_genNONE, FFEINTRIN_specJISHFT,},    /* VXT */
  289. {"JISHFTC", "jishftc", "JIShftC", FFEINTRIN_genNONE, FFEINTRIN_specJISHFTC,},    /* VXT */
  290.   {"JISIGN", "jisign", "JISign", FFEINTRIN_genNONE, FFEINTRIN_specJISIGN,},    /* VXT */
  291.   {"JMAX0", "jmax0", "JMax0", FFEINTRIN_genNONE, FFEINTRIN_specJMAX0,},    /* VXT */
  292.   {"JMAX1", "jmax1", "JMax1", FFEINTRIN_genNONE, FFEINTRIN_specJMAX1,},    /* VXT */
  293.   {"JMIN0", "jmin0", "JMin0", FFEINTRIN_genNONE, FFEINTRIN_specJMIN0,},    /* VXT */
  294.   {"JMIN1", "jmin1", "JMin1", FFEINTRIN_genNONE, FFEINTRIN_specJMIN1,},    /* VXT */
  295.   {"JMOD", "jmod", "JMod", FFEINTRIN_genNONE, FFEINTRIN_specJMOD,},    /* VXT */
  296.   {"JNINT", "jnint", "JNInt", FFEINTRIN_genNONE, FFEINTRIN_specJNINT,},    /* VXT */
  297.   {"JNOT", "jnot", "JNot", FFEINTRIN_genNONE, FFEINTRIN_specJNOT,},    /* VXT */
  298.   {"JZEXT", "jzext", "JZExt", FFEINTRIN_genNONE, FFEINTRIN_specJZEXT,},    /* VXT */
  299.   {"KIND", "kind", "Kind", FFEINTRIN_genKIND, FFEINTRIN_specNONE,},    /* F90 */
  300.   {"LBOUND", "lbound", "LBound", FFEINTRIN_genLBOUND, FFEINTRIN_specNONE,},    /* F90 */
  301.   {"LEN", "len", "Len", FFEINTRIN_genLEN, FFEINTRIN_specLEN,},
  302.   {"LEN_TRIM", "len_trim", "Len_Trim", FFEINTRIN_genLEN_TRIM, FFEINTRIN_specNONE,},    /* F90 */
  303.   {"LGE", "lge", "LGe", FFEINTRIN_genLGE, FFEINTRIN_specLGE,},
  304.   {"LGT", "lgt", "LGt", FFEINTRIN_genLGT, FFEINTRIN_specLGT,},
  305.   {"LLE", "lle", "LLe", FFEINTRIN_genLLE, FFEINTRIN_specLLE,},
  306.   {"LLT", "llt", "LLt", FFEINTRIN_genLLT, FFEINTRIN_specLLT,},
  307.   {"LOC", "loc", "Loc", FFEINTRIN_genNONE, FFEINTRIN_specLOC,},    /* VXT */
  308.   {"LOG", "log", "Log", FFEINTRIN_genLOG, FFEINTRIN_specNONE,},
  309.   {"LOG10", "log10", "Log10", FFEINTRIN_genLOG10, FFEINTRIN_specNONE,},
  310. {"LOGICAL", "logical", "Logical", FFEINTRIN_genLOGICAL, FFEINTRIN_specNONE,},    /* F90 */
  311.   {"LSHIFT", "lshift", "LShift", FFEINTRIN_genLSHIFT, FFEINTRIN_specNONE,},    /* F2C */
  312.   {"MATMUL", "matmul", "MatMul", FFEINTRIN_genMATMUL, FFEINTRIN_specNONE,},    /* F90 */
  313.   {"MAX", "max", "Max", FFEINTRIN_genMAX, FFEINTRIN_specNONE,},
  314.   {"MAX0", "max0", "Max0", FFEINTRIN_genMAX0, FFEINTRIN_specMAX0,},
  315.   {"MAX1", "max1", "Max1", FFEINTRIN_genMAX1, FFEINTRIN_specMAX1,},
  316.   {"MAXEXPONENT", "maxexponent", "MaxExponent", FFEINTRIN_genMAXEXPONENT, FFEINTRIN_specNONE,},    /* F90 */
  317.   {"MAXLOC", "maxloc", "MaxLoc", FFEINTRIN_genMAXLOC, FFEINTRIN_specNONE,},    /* F90 */
  318.   {"MAXVAL", "maxval", "MaxVal", FFEINTRIN_genMAXVAL, FFEINTRIN_specNONE,},    /* F90 */
  319.   {"MERGE", "merge", "Merge", FFEINTRIN_genMERGE, FFEINTRIN_specNONE,},    /* F90 */
  320.   {"MIN", "min", "Min", FFEINTRIN_genMIN, FFEINTRIN_specNONE,},
  321.   {"MIN0", "min0", "Min0", FFEINTRIN_genMIN0, FFEINTRIN_specMIN0,},
  322.   {"MIN1", "min1", "Min1", FFEINTRIN_genMIN1, FFEINTRIN_specMIN1,},
  323.   {"MINEXPONENT", "minexponent", "MinExponent", FFEINTRIN_genMINEXPONENT, FFEINTRIN_specNONE,},    /* F90 */
  324.   {"MINLOC", "minloc", "MinLoc", FFEINTRIN_genMINLOC, FFEINTRIN_specNONE,},    /* F90 */
  325.   {"MINVAL", "minval", "MinVal", FFEINTRIN_genMINVAL, FFEINTRIN_specNONE,},    /* F90 */
  326.   {"MOD", "mod", "Mod", FFEINTRIN_genMOD, FFEINTRIN_specMOD,},
  327.   {"MODULO", "modulo", "Modulo", FFEINTRIN_genMODULO, FFEINTRIN_specNONE,},    /* F90 */
  328.   {"MVBITS", "mvbits", "MvBits", FFEINTRIN_genMVBITS, FFEINTRIN_specNONE,},    /* F90 */
  329. {"NEAREST", "nearest", "Nearest", FFEINTRIN_genNEAREST, FFEINTRIN_specNONE,},    /* F90 */
  330.   {"NINT", "nint", "NInt", FFEINTRIN_genNINT, FFEINTRIN_specNINT,},
  331.   {"NOT", "not", "Not", FFEINTRIN_genNOT, FFEINTRIN_specNONE,},    /* F2C, F90, VXT */
  332.   {"OR", "or", "Or", FFEINTRIN_genOR, FFEINTRIN_specNONE,},    /* F2C */
  333.   {"PACK", "pack", "Pack", FFEINTRIN_genPACK, FFEINTRIN_specNONE,},    /* F90 */
  334.   {"PRECISION", "precision", "Precision", FFEINTRIN_genPRECISION, FFEINTRIN_specNONE,},    /* F90 */
  335. {"PRESENT", "present", "Present", FFEINTRIN_genPRESENT, FFEINTRIN_specNONE,},    /* F90 */
  336. {"PRODUCT", "product", "Product", FFEINTRIN_genPRODUCT, FFEINTRIN_specNONE,},    /* F90 */
  337.   {"QABS", "qabs", "QAbs", FFEINTRIN_genNONE, FFEINTRIN_specQABS,},    /* VXT */
  338.   {"QACOS", "qacos", "QACos", FFEINTRIN_genNONE, FFEINTRIN_specQACOS,},    /* VXT */
  339.   {"QACOSD", "qacosd", "QACosD", FFEINTRIN_genNONE, FFEINTRIN_specQACOSD,},    /* VXT */
  340.   {"QASIN", "qasin", "QASin", FFEINTRIN_genNONE, FFEINTRIN_specQASIN,},    /* VXT */
  341.   {"QASIND", "qasind", "QASinD", FFEINTRIN_genNONE, FFEINTRIN_specQASIND,},    /* VXT */
  342.   {"QATAN", "qatan", "QATan", FFEINTRIN_genNONE, FFEINTRIN_specQATAN,},    /* VXT */
  343.   {"QATAN2", "qatan2", "QATan2", FFEINTRIN_genNONE, FFEINTRIN_specQATAN2,},    /* VXT */
  344. {"QATAN2D", "qatan2d", "QATan2D", FFEINTRIN_genNONE, FFEINTRIN_specQATAN2D,},    /* VXT */
  345.   {"QATAND", "qatand", "QATanD", FFEINTRIN_genNONE, FFEINTRIN_specQATAND,},    /* VXT */
  346.   {"QCOS", "qcos", "QCos", FFEINTRIN_genNONE, FFEINTRIN_specQCOS,},    /* VXT */
  347.   {"QCOSD", "qcosd", "QCosD", FFEINTRIN_genNONE, FFEINTRIN_specQCOSD,},    /* VXT */
  348.   {"QCOSH", "qcosh", "QCosH", FFEINTRIN_genNONE, FFEINTRIN_specQCOSH,},    /* VXT */
  349.   {"QDIM", "qdim", "QDiM", FFEINTRIN_genNONE, FFEINTRIN_specQDIM,},    /* VXT */
  350.   {"QEXP", "qexp", "QExp", FFEINTRIN_genNONE, FFEINTRIN_specQEXP,},    /* VXT */
  351.   {"QEXT", "qext", "QExt", FFEINTRIN_genQEXT, FFEINTRIN_specQEXT,},    /* VXT */
  352.   {"QEXTD", "qextd", "QExtD", FFEINTRIN_genNONE, FFEINTRIN_specQEXTD,},    /* VXT */
  353.   {"QFLOAT", "qfloat", "QFloat", FFEINTRIN_genQFLOAT, FFEINTRIN_specNONE,},    /* VXT */
  354.   {"QINT", "qint", "QInt", FFEINTRIN_genNONE, FFEINTRIN_specQINT,},    /* VXT */
  355.   {"QLOG", "qlog", "QLog", FFEINTRIN_genNONE, FFEINTRIN_specQLOG,},    /* VXT */
  356.   {"QLOG10", "qlog10", "QLog10", FFEINTRIN_genNONE, FFEINTRIN_specQLOG10,},    /* VXT */
  357.   {"QMAX1", "qmax1", "QMax1", FFEINTRIN_genNONE, FFEINTRIN_specQMAX1,},    /* VXT */
  358.   {"QMIN1", "qmin1", "QMin1", FFEINTRIN_genNONE, FFEINTRIN_specQMIN1,},    /* VXT */
  359.   {"QMOD", "qmod", "QMod", FFEINTRIN_genNONE, FFEINTRIN_specQMOD,},    /* VXT */
  360.   {"QNINT", "qnint", "QNInt", FFEINTRIN_genNONE, FFEINTRIN_specQNINT,},    /* VXT */
  361.   {"QSIN", "qsin", "QSin", FFEINTRIN_genNONE, FFEINTRIN_specQSIN,},    /* VXT */
  362.   {"QSIND", "qsind", "QSinD", FFEINTRIN_genNONE, FFEINTRIN_specQSIND,},    /* VXT */
  363.   {"QSINH", "qsinh", "QSinH", FFEINTRIN_genNONE, FFEINTRIN_specQSINH,},    /* VXT */
  364.   {"QSQRT", "qsqrt", "QSqRt", FFEINTRIN_genNONE, FFEINTRIN_specQSQRT,},    /* VXT */
  365.   {"QTAN", "qtan", "QTan", FFEINTRIN_genNONE, FFEINTRIN_specQTAN,},    /* VXT */
  366.   {"QTAND", "qtand", "QTanD", FFEINTRIN_genNONE, FFEINTRIN_specQTAND,},    /* VXT */
  367.   {"QTANH", "qtanh", "QTanH", FFEINTRIN_genNONE, FFEINTRIN_specQTANH,},    /* VXT */
  368.   {"RADIX", "radix", "Radix", FFEINTRIN_genRADIX, FFEINTRIN_specNONE,},    /* F90 */
  369.   {"RANDOM_NUMBER", "random_number", "Random_Number", FFEINTRIN_genNONE, FFEINTRIN_specRANDOM_NUMBER,},    /* F90 */
  370.   {"RANDOM_SEED", "random_seed", "Random_Seed", FFEINTRIN_genNONE, FFEINTRIN_specRANDOM_SEED,},    /* F90 */
  371.   {"RANGE", "range", "Range", FFEINTRIN_genRANGE, FFEINTRIN_specNONE,},    /* F90 */
  372.   {"REAL", "real", "Real", FFEINTRIN_genREAL, FFEINTRIN_specREAL,},
  373.   {"REPEAT", "repeat", "Repeat", FFEINTRIN_genREPEAT, FFEINTRIN_specNONE,},    /* F90 */
  374. {"RESHAPE", "reshape", "Reshape", FFEINTRIN_genRESHAPE, FFEINTRIN_specNONE,},    /* F90 */
  375.   {"RRSPACING", "rrspacing", "RRSpacing", FFEINTRIN_genRRSPACING, FFEINTRIN_specNONE,},    /* F90 */
  376.   {"RSHIFT", "rshift", "RShift", FFEINTRIN_genRSHIFT, FFEINTRIN_specNONE,},    /* F2C */
  377.   {"SCALE", "scale", "Scale", FFEINTRIN_genSCALE, FFEINTRIN_specNONE,},    /* F90 */
  378.   {"SCAN", "scan", "Scan", FFEINTRIN_genSCAN, FFEINTRIN_specNONE,},    /* F90 */
  379.   {"SELECTED_INT_KIND", "selected_int_kind", "Selected_Int_Kind", FFEINTRIN_genSEL_INT_KIND, FFEINTRIN_specNONE,},    /* F90 */
  380.   {"SELECTED_REAL_KIND", "selected_real_kind", "Selected_Real_Kind", FFEINTRIN_genSEL_REAL_KIND, FFEINTRIN_specNONE,},    /* F90 */
  381.   {"SET_EXPONENT", "set_exponent", "Set_Exponent", FFEINTRIN_genSET_EXPONENT, FFEINTRIN_specNONE,},    /* F90 */
  382.   {"SHAPE", "shape", "Shape", FFEINTRIN_genSHAPE, FFEINTRIN_specNONE,},    /* F90 */
  383.   {"SIGN", "sign", "Sign", FFEINTRIN_genSIGN, FFEINTRIN_specSIGN,},
  384.   {"SIN", "sin", "Sin", FFEINTRIN_genSIN, FFEINTRIN_specSIN,},
  385.   {"SIND", "sind", "SinD", FFEINTRIN_genSIND, FFEINTRIN_specSIND,},    /* VXT */
  386.   {"SINH", "sinh", "SinH", FFEINTRIN_genSINH, FFEINTRIN_specSINH,},
  387.   {"SNGL", "sngl", "Sngl", FFEINTRIN_genNONE, FFEINTRIN_specSNGL,},
  388.   {"SNGLQ", "snglq", "SnglQ", FFEINTRIN_genNONE, FFEINTRIN_specSNGLQ,},    /* VXT */
  389. {"SPACING", "spacing", "Spacing", FFEINTRIN_genSPACING, FFEINTRIN_specNONE,},    /* F90 */
  390.   {"SPREAD", "spread", "Spread", FFEINTRIN_genSPREAD, FFEINTRIN_specNONE,},    /* F90 */
  391.   {"SQRT", "sqrt", "SqRt", FFEINTRIN_genSQRT, FFEINTRIN_specSQRT,},
  392.   {"SUM", "sum", "Sum", FFEINTRIN_genSUM, FFEINTRIN_specNONE,},    /* F90 */
  393.   {"SYSTEM_CLOCK", "system_clock", "System_Clock", FFEINTRIN_genNONE, FFEINTRIN_specSYSTEM_CLOCK,},    /* F90 */
  394.   {"TAN", "tan", "Tan", FFEINTRIN_genTAN, FFEINTRIN_specTAN,},
  395.   {"TAND", "tand", "TanD", FFEINTRIN_genTAND, FFEINTRIN_specTAND,},    /* VXT */
  396.   {"TANH", "tanh", "TanH", FFEINTRIN_genTANH, FFEINTRIN_specTANH,},
  397.   {"TINY", "tiny", "Tiny", FFEINTRIN_genTINY, FFEINTRIN_specNONE,},    /* F90 */
  398.   {"TRANSFER", "transfer", "Transfer", FFEINTRIN_genTRANSFER, FFEINTRIN_specNONE,},    /* F90 */
  399.   {"TRANSPOSE", "transpose", "Transpose", FFEINTRIN_genTRANSPOSE, FFEINTRIN_specNONE,},    /* F90 */
  400.   {"TRIM", "trim", "Trim", FFEINTRIN_genTRIM, FFEINTRIN_specNONE,},    /* F90 */
  401.   {"UBOUND", "ubound", "UBound", FFEINTRIN_genUBOUND, FFEINTRIN_specNONE,},    /* F90 */
  402.   {"UNPACK", "unpack", "Unpack", FFEINTRIN_genUNPACK, FFEINTRIN_specNONE,},    /* F90 */
  403.   {"VERIFY", "verify", "Verify", FFEINTRIN_genVERIFY, FFEINTRIN_specNONE,},    /* F90 */
  404.   {"XOR", "xor", "XOr", FFEINTRIN_genXOR, FFEINTRIN_specNONE,},    /* F2C */
  405.   {"ZABS", "zabs", "ZAbs", FFEINTRIN_genNONE, FFEINTRIN_specZABS,},    /* F2C */
  406.   {"ZCOS", "zcos", "ZCos", FFEINTRIN_genNONE, FFEINTRIN_specZCOS,},    /* F2C */
  407.   {"ZEXP", "zexp", "ZExp", FFEINTRIN_genNONE, FFEINTRIN_specZEXP,},    /* F2C */
  408.   {"ZEXT", "zext", "ZExt", FFEINTRIN_genZEXT, FFEINTRIN_specZEXT,},    /* VXT */
  409.   {"ZLOG", "zlog", "ZLog", FFEINTRIN_genNONE, FFEINTRIN_specZLOG,},    /* F2C */
  410.   {"ZSIN", "zsin", "ZSin", FFEINTRIN_genNONE, FFEINTRIN_specZSIN,},    /* F2C */
  411.   {"ZSQRT", "zsqrt", "ZSqRt", FFEINTRIN_genNONE, FFEINTRIN_specZSQRT,},    /* F2C */
  412. };
  413.  
  414. static struct _ffeintrin_gen_ ffeintrin_gens_[]
  415. =
  416. {
  417. #define DEFGEN(CODE,NAME,SPEC1,SPEC2,SPEC3,SPEC4,SPEC5,SPEC6, \
  418.   SPEC7,SPEC8,SPEC9,SPEC10,SPEC11,SPEC12,SPEC13,SPEC14) \
  419.   { NAME, { SPEC1, SPEC2, SPEC3, SPEC4, SPEC5, SPEC6, \
  420.     SPEC7, SPEC8, SPEC9, SPEC10, SPEC11, SPEC12, SPEC13, SPEC14, }, },
  421. #define DEFIMP(CODE,NAME,GFRT,RETURNS,EXPECTS)
  422. #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
  423. #include "intrin.def"
  424. #undef DEFGEN
  425. #undef DEFIMP
  426. #undef DEFSPEC
  427. };
  428.  
  429. static struct _ffeintrin_imp_ ffeintrin_imps_[]
  430. =
  431. {
  432. #define DEFGEN(CODE,NAME,SPEC1,SPEC2,SPEC3,SPEC4,SPEC5,SPEC6, \
  433.   SPEC7,SPEC8,SPEC9,SPEC10,SPEC11,SPEC12,SPEC13,SPEC14)
  434. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  435. #define DEFIMP(CODE,NAME,GFRT,RETURNS,EXPECTS) \
  436.       { NAME, GFRT, RETURNS, EXPECTS },
  437. #endif
  438. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  439. #define DEFIMP(CODE,NAME,GFRT,RETURNS,EXPECTS) \
  440.       { NAME, RETURNS, EXPECTS },
  441. #endif
  442. #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
  443. #include "intrin.def"
  444. #undef DEFGEN
  445. #undef DEFIMP
  446. #undef DEFSPEC
  447. };
  448.  
  449. static struct _ffeintrin_spec_ ffeintrin_specs_[]
  450. =
  451. {
  452. #define DEFGEN(CODE,NAME,SPEC1,SPEC2,SPEC3,SPEC4,SPEC5,SPEC6, \
  453.   SPEC7,SPEC8,SPEC9,SPEC10,SPEC11,SPEC12,SPEC13,SPEC14)
  454. #define DEFIMP(CODE,NAME,GFRT,RETURNS,EXPECTS)
  455. #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
  456.   { NAME, CALLABLE, FAMILY, IMP, },
  457. #include "intrin.def"
  458. #undef DEFGEN
  459. #undef DEFIMP
  460. #undef DEFSPEC
  461. };
  462.  
  463.  
  464. static ffebad
  465. ffeintrin_check_1_ (ffebld arglist, ffebld *xarg1)
  466. {
  467.   ffebld arg1;
  468.  
  469.   arg1 = arglist;
  470.   if (arg1 == NULL)
  471.     return FFEBAD_INTRINSIC_TOOFEW;
  472.  
  473.   if (ffebld_trail (arg1) != NULL)
  474.     return FFEBAD_INTRINSIC_TOOMANY;
  475.  
  476.   if ((arg1 = ffebld_head (arg1)) == NULL)
  477.     return FFEBAD_INTRINSIC_REF;
  478.  
  479.   *xarg1 = arg1;
  480.   return FFEBAD;
  481. }
  482.  
  483. static ffebad
  484. ffeintrin_check_1or2_ (ffebld arglist, ffebld *xarg1, ffebld *xarg2)
  485. {
  486.   ffebld arg1;
  487.   ffebld arg2;
  488.  
  489.   arg1 = arglist;
  490.   if (arg1 == NULL)
  491.     return FFEBAD_INTRINSIC_TOOFEW;
  492.  
  493.   arg2 = ffebld_trail (arg1);
  494.   if ((arg2 != NULL)
  495.       && (ffebld_trail (arg2) != NULL))
  496.     return FFEBAD_INTRINSIC_TOOMANY;
  497.  
  498.   if (((arg1 = ffebld_head (arg1)) == NULL)
  499.       || ((arg2 != NULL)
  500.       && ((arg2 = ffebld_head (arg2)) == NULL)))
  501.     return FFEBAD_INTRINSIC_REF;
  502.  
  503.   *xarg1 = arg1;
  504.   *xarg2 = arg2;
  505.   return FFEBAD;
  506. }
  507.  
  508. static ffebad
  509. ffeintrin_check_2_ (ffebld arglist, ffebld *xarg1, ffebld *xarg2)
  510. {
  511.   ffebld arg1;
  512.   ffebld arg2;
  513.  
  514.   arg1 = arglist;
  515.   if (arg1 == NULL)
  516.     return FFEBAD_INTRINSIC_TOOFEW;
  517.  
  518.   arg2 = ffebld_trail (arg1);
  519.   if (arg2 == NULL)
  520.     return FFEBAD_INTRINSIC_TOOFEW;
  521.  
  522.   if (ffebld_trail (arg2) != NULL)
  523.     return FFEBAD_INTRINSIC_TOOMANY;
  524.  
  525.   if (((arg1 = ffebld_head (arg1)) == NULL)
  526.       || ((arg2 = ffebld_head (arg2)) == NULL))
  527.     return FFEBAD_INTRINSIC_REF;
  528.  
  529.   *xarg1 = arg1;
  530.   *xarg2 = arg2;
  531.   return FFEBAD;
  532. }
  533.  
  534. static ffebad
  535. ffeintrin_check_3_ (ffebld arglist, ffebld *xarg1, ffebld *xarg2,
  536.             ffebld *xarg3)
  537. {
  538.   ffebld arg1;
  539.   ffebld arg2;
  540.   ffebld arg3;
  541.  
  542.   arg1 = arglist;
  543.   if (arg1 == NULL)
  544.     return FFEBAD_INTRINSIC_TOOFEW;
  545.  
  546.   arg2 = ffebld_trail (arg1);
  547.   if (arg2 == NULL)
  548.     return FFEBAD_INTRINSIC_TOOFEW;
  549.  
  550.   arg3 = ffebld_trail (arg2);
  551.   if (arg3 == NULL)
  552.     return FFEBAD_INTRINSIC_TOOFEW;
  553.  
  554.   if (ffebld_trail (arg3) != NULL)
  555.     return FFEBAD_INTRINSIC_TOOMANY;
  556.  
  557.   if (((arg1 = ffebld_head (arg1)) == NULL)
  558.       || ((arg2 = ffebld_head (arg2)) == NULL)
  559.       || ((arg3 = ffebld_head (arg3)) == NULL))
  560.     return FFEBAD_INTRINSIC_REF;
  561.  
  562.   *xarg1 = arg1;
  563.   *xarg2 = arg2;
  564.   *xarg3 = arg3;
  565.   return FFEBAD;
  566. }
  567.  
  568. static ffebad
  569. ffeintrin_check_5_ (ffebld arglist, ffebld *xarg1, ffebld *xarg2,
  570.             ffebld *xarg3, ffebld *xarg4, ffebld *xarg5)
  571. {
  572.   ffebld arg1;
  573.   ffebld arg2;
  574.   ffebld arg3;
  575.   ffebld arg4;
  576.   ffebld arg5;
  577.  
  578.   arg1 = arglist;
  579.   if (arg1 == NULL)
  580.     return FFEBAD_INTRINSIC_TOOFEW;
  581.  
  582.   arg2 = ffebld_trail (arg1);
  583.   if (arg2 == NULL)
  584.     return FFEBAD_INTRINSIC_TOOFEW;
  585.  
  586.   arg3 = ffebld_trail (arg2);
  587.   if (arg3 == NULL)
  588.     return FFEBAD_INTRINSIC_TOOFEW;
  589.  
  590.   arg4 = ffebld_trail (arg3);
  591.   if (arg4 == NULL)
  592.     return FFEBAD_INTRINSIC_TOOFEW;
  593.  
  594.   arg5 = ffebld_trail (arg4);
  595.   if (arg5 == NULL)
  596.     return FFEBAD_INTRINSIC_TOOFEW;
  597.  
  598.   if (ffebld_trail (arg5) != NULL)
  599.     return FFEBAD_INTRINSIC_TOOMANY;
  600.  
  601.   if (((arg1 = ffebld_head (arg1)) == NULL)
  602.       || ((arg2 = ffebld_head (arg2)) == NULL)
  603.       || ((arg3 = ffebld_head (arg3)) == NULL)
  604.       || ((arg4 = ffebld_head (arg4)) == NULL)
  605.       || ((arg5 = ffebld_head (arg5)) == NULL))
  606.     return FFEBAD_INTRINSIC_REF;
  607.  
  608.   *xarg1 = arg1;
  609.   *xarg2 = arg2;
  610.   *xarg3 = arg3;
  611.   *xarg4 = arg4;
  612.   *xarg5 = arg5;
  613.   return FFEBAD;
  614. }
  615.  
  616. static bool
  617. ffeintrin_check_any_ (ffebld arglist)
  618. {
  619.   ffebld item;
  620.  
  621.   for (; arglist != NULL; arglist = ffebld_trail (arglist))
  622.     {
  623.       item = ffebld_head (arglist);
  624.       if ((item != NULL)
  625.       && (ffebld_op (item) == FFEBLD_opANY))
  626.     return TRUE;
  627.     }
  628.  
  629.   return FALSE;
  630. }
  631.  
  632. static ffebad
  633. ffeintrin_check_char_1_ (ffebld arglist)
  634. {
  635.   ffebld arg1;
  636.   ffeinfo info;
  637.   ffebad bad;
  638.  
  639.   bad = ffeintrin_check_1_ (arglist, &arg1);
  640.   if (bad != FFEBAD)
  641.     return bad;
  642.  
  643.   info = ffebld_info (arg1);
  644.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
  645.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
  646.       || (ffeinfo_rank (info) != 0)
  647.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  648.     return FFEBAD_INTRINSIC_REF;
  649.  
  650.   return FFEBAD;        /* Ok. */
  651. }
  652.  
  653. static ffebad
  654. ffeintrin_check_char_2_ (ffebld arglist)
  655. {
  656.   ffebld arg1;
  657.   ffebld arg2;
  658.   ffeinfo info;
  659.   ffebad bad;
  660.  
  661.   bad = ffeintrin_check_2_ (arglist, &arg1, &arg2);
  662.   if (bad != FFEBAD)
  663.     return bad;
  664.  
  665.   info = ffebld_info (arg1);
  666.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
  667.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
  668.       || (ffeinfo_rank (info) != 0)
  669.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  670.     return FFEBAD_INTRINSIC_REF;
  671.  
  672.   info = ffebld_info (arg2);
  673.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
  674.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
  675.       || (ffeinfo_rank (info) != 0)
  676.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  677.     return FFEBAD_INTRINSIC_REF;
  678.  
  679.   return FFEBAD;        /* Ok. */
  680. }
  681.  
  682. static ffebad
  683. ffeintrin_check_cmplx_1_ (ffebld arglist)
  684. {
  685.   ffebld arg1;
  686.   ffeinfo info;
  687.   ffebad bad;
  688.  
  689.   bad = ffeintrin_check_1_ (arglist, &arg1);
  690.   if (bad != FFEBAD)
  691.     return bad;
  692.  
  693.   info = ffebld_info (arg1);
  694.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  695.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  696.       || (ffeinfo_rank (info) != 0)
  697.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  698.     return FFEBAD_INTRINSIC_REF;
  699.  
  700.   return FFEBAD;        /* Ok. */
  701. }
  702.  
  703. static ffebad
  704. ffeintrin_check_cmplx_1or2_ (ffebld arglist)
  705. {
  706.   ffebld arg1;
  707.   ffebld arg2;
  708.   ffeinfo info;
  709.   ffebad bad;
  710.  
  711.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  712.   if (bad != FFEBAD)
  713.     return bad;
  714.  
  715.   info = ffebld_info (arg1);
  716.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  717.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  718.       || (ffeinfo_rank (info) != 0)
  719.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  720.     return FFEBAD_INTRINSIC_REF;
  721.  
  722.   if (arg2 == NULL)
  723.     return FFEBAD;        /* Ok. */
  724.  
  725.   info = ffebld_info (arg2);
  726.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  727.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  728.       || (ffeinfo_rank (info) != 0)
  729.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  730.     return FFEBAD_INTRINSIC_REF;
  731.  
  732.   return FFEBAD;        /* Ok. */
  733. }
  734.  
  735. static ffebad
  736. ffeintrin_check_dcmplx_1_ (ffebld arglist)
  737. {
  738.   ffebld arg1;
  739.   ffeinfo info;
  740.   ffebad bad;
  741.  
  742.   bad = ffeintrin_check_1_ (arglist, &arg1);
  743.   if (bad != FFEBAD)
  744.     return bad;
  745.  
  746.   info = ffebld_info (arg1);
  747.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  748.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  749.       || (ffeinfo_rank (info) != 0)
  750.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  751.     return FFEBAD_INTRINSIC_REF;
  752.  
  753.   return FFEBAD;        /* Ok. */
  754. }
  755.  
  756. static ffebad
  757. ffeintrin_check_dcmplx_1or2_ (ffebld arglist)
  758. {
  759.   ffebld arg1;
  760.   ffebld arg2;
  761.   ffeinfo info;
  762.   ffebad bad;
  763.  
  764.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  765.   if (bad != FFEBAD)
  766.     return bad;
  767.  
  768.   info = ffebld_info (arg1);
  769.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  770.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  771.       || (ffeinfo_rank (info) != 0)
  772.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  773.     return FFEBAD_INTRINSIC_REF;
  774.  
  775.   if (arg2 == NULL)
  776.     return FFEBAD;        /* Ok. */
  777.  
  778.   info = ffebld_info (arg2);
  779.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeCOMPLEX)
  780.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  781.       || (ffeinfo_rank (info) != 0)
  782.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  783.     return FFEBAD_INTRINSIC_REF;
  784.  
  785.   return FFEBAD;        /* Ok. */
  786. }
  787.  
  788. static ffebad
  789. ffeintrin_check_int_1_ (ffebld arglist)
  790. {
  791.   ffebld arg1;
  792.   ffeinfo info;
  793.   ffebad bad;
  794.  
  795.   bad = ffeintrin_check_1_ (arglist, &arg1);
  796.   if (bad != FFEBAD)
  797.     return bad;
  798.  
  799.   info = ffebld_info (arg1);
  800.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  801.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  802.       || (ffeinfo_rank (info) != 0)
  803.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  804.     return FFEBAD_INTRINSIC_REF;
  805.  
  806.   return FFEBAD;        /* Ok. */
  807. }
  808.  
  809. static ffebad
  810. ffeintrin_check_int_1or2_ (ffebld arglist)
  811. {
  812.   ffebld arg1;
  813.   ffebld arg2;
  814.   ffeinfo info;
  815.   ffebad bad;
  816.  
  817.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  818.   if (bad != FFEBAD)
  819.     return bad;
  820.  
  821.   info = ffebld_info (arg1);
  822.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  823.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  824.       || (ffeinfo_rank (info) != 0)
  825.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  826.     return FFEBAD_INTRINSIC_REF;
  827.  
  828.   if (arg2 == NULL)
  829.     return FFEBAD;        /* Ok. */
  830.  
  831.   info = ffebld_info (arg2);
  832.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  833.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  834.       || (ffeinfo_rank (info) != 0)
  835.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  836.     return FFEBAD_INTRINSIC_REF;
  837.  
  838.   return FFEBAD;        /* Ok. */
  839. }
  840.  
  841. static ffebad
  842. ffeintrin_check_int_2_ (ffebld arglist)
  843. {
  844.   ffebld arg1;
  845.   ffebld arg2;
  846.   ffeinfo info;
  847.   ffebad bad;
  848.  
  849.   bad = ffeintrin_check_2_ (arglist, &arg1, &arg2);
  850.   if (bad != FFEBAD)
  851.     return bad;
  852.  
  853.   info = ffebld_info (arg1);
  854.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  855.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  856.       || (ffeinfo_rank (info) != 0)
  857.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  858.     return FFEBAD_INTRINSIC_REF;
  859.  
  860.   info = ffebld_info (arg2);
  861.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  862.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  863.       || (ffeinfo_rank (info) != 0)
  864.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  865.     return FFEBAD_INTRINSIC_REF;
  866.  
  867.   return FFEBAD;        /* Ok. */
  868. }
  869.  
  870. static ffebad
  871. ffeintrin_check_int_2p_ (ffebld arglist)
  872. {
  873.   ffebld arg;
  874.   ffebldListLength length = 0;
  875.   ffeinfo info;
  876.  
  877.   for (; arglist != NULL; ++length, arglist = ffebld_trail (arglist))
  878.     {
  879.       if ((arg = ffebld_head (arglist)) == NULL)
  880.     return FFEBAD_INTRINSIC_REF;
  881.  
  882.       info = ffebld_info (arg);
  883.       if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  884.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  885.       || (ffeinfo_rank (info) != 0)
  886.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  887.     return FFEBAD_INTRINSIC_REF;
  888.     }
  889.  
  890.   if (length < 2)
  891.     return FFEBAD_INTRINSIC_TOOFEW;
  892.  
  893.   return FFEBAD;        /* Ok. */
  894. }
  895.  
  896. static ffebad
  897. ffeintrin_check_int_3_ (ffebld arglist)
  898. {
  899.   ffebld arg1;
  900.   ffebld arg2;
  901.   ffebld arg3;
  902.   ffeinfo info;
  903.   ffebad bad;
  904.  
  905.   bad = ffeintrin_check_3_ (arglist, &arg1, &arg2, &arg3);
  906.   if (bad != FFEBAD)
  907.     return bad;
  908.  
  909.   info = ffebld_info (arg1);
  910.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  911.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  912.       || (ffeinfo_rank (info) != 0)
  913.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  914.     return FFEBAD_INTRINSIC_REF;
  915.  
  916.   info = ffebld_info (arg2);
  917.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  918.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  919.       || (ffeinfo_rank (info) != 0)
  920.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  921.     return FFEBAD_INTRINSIC_REF;
  922.  
  923.   info = ffebld_info (arg3);
  924.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  925.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  926.       || (ffeinfo_rank (info) != 0)
  927.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  928.     return FFEBAD_INTRINSIC_REF;
  929.  
  930.   return FFEBAD;        /* Ok. */
  931. }
  932.  
  933. static ffebad
  934. ffeintrin_check_loc_ (ffebld arglist)
  935. {
  936.   ffebld arg1;
  937.   ffeinfo info;
  938.   ffebad bad;
  939.  
  940.   bad = ffeintrin_check_1_ (arglist, &arg1);
  941.   if (bad != FFEBAD)
  942.     return bad;
  943.  
  944.   /* See also ffeexpr_finished_, case FFEEXPR_contextLOC_.  */
  945.   info = ffebld_info (arg1);
  946.   if ((ffeinfo_kind (info) != FFEINFO_kindENTITY)
  947.       || ((ffebld_op (arg1) != FFEBLD_opSYMTER)
  948.       && (ffebld_op (arg1) != FFEBLD_opSUBSTR)
  949.       && (ffebld_op (arg1) != FFEBLD_opARRAYREF)))
  950.     return FFEBAD_INTRINSIC_REF;
  951.  
  952.   return FFEBAD;        /* Ok. */
  953. }
  954.  
  955. static ffebad
  956. ffeintrin_check_log_1_ (ffebld arglist)
  957. {
  958.   ffebld arg1;
  959.   ffeinfo info;
  960.   ffebad bad;
  961.  
  962.   bad = ffeintrin_check_1_ (arglist, &arg1);
  963.   if (bad != FFEBAD)
  964.     return bad;
  965.  
  966.   info = ffebld_info (arg1);
  967.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  968.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  969.       || (ffeinfo_rank (info) != 0)
  970.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  971.     return FFEBAD_INTRINSIC_REF;
  972.  
  973.   return FFEBAD;        /* Ok. */
  974. }
  975.  
  976. #if 0
  977. static ffebad
  978. ffeintrin_check_log_1or2_ (ffebld arglist)
  979. {
  980.   ffebld arg1;
  981.   ffebld arg2;
  982.   ffeinfo info;
  983.   ffebad bad;
  984.  
  985.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  986.   if (bad != FFEBAD)
  987.     return bad;
  988.  
  989.   info = ffebld_info (arg1);
  990.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  991.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  992.       || (ffeinfo_rank (info) != 0)
  993.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  994.     return FFEBAD_INTRINSIC_REF;
  995.  
  996.   if (arg2 == NULL)
  997.     return FFEBAD;        /* Ok. */
  998.  
  999.   info = ffebld_info (arg2);
  1000.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  1001.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  1002.       || (ffeinfo_rank (info) != 0)
  1003.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1004.     return FFEBAD_INTRINSIC_REF;
  1005.  
  1006.   return FFEBAD;        /* Ok. */
  1007. }
  1008.  
  1009. #endif
  1010. static ffebad
  1011. ffeintrin_check_log_2_ (ffebld arglist)
  1012. {
  1013.   ffebld arg1;
  1014.   ffebld arg2;
  1015.   ffeinfo info;
  1016.   ffebad bad;
  1017.  
  1018.   bad = ffeintrin_check_2_ (arglist, &arg1, &arg2);
  1019.   if (bad != FFEBAD)
  1020.     return bad;
  1021.  
  1022.   info = ffebld_info (arg1);
  1023.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  1024.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  1025.       || (ffeinfo_rank (info) != 0)
  1026.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1027.     return FFEBAD_INTRINSIC_REF;
  1028.  
  1029.   info = ffebld_info (arg2);
  1030.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  1031.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  1032.       || (ffeinfo_rank (info) != 0)
  1033.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1034.     return FFEBAD_INTRINSIC_REF;
  1035.  
  1036.   return FFEBAD;        /* Ok. */
  1037. }
  1038.  
  1039. #if 0
  1040. static ffebad
  1041. ffeintrin_check_log_2p_ (ffebld arglist)
  1042. {
  1043.   ffebld arg;
  1044.   ffebldListLength length = 0;
  1045.   ffeinfo info;
  1046.  
  1047.   for (; arglist != NULL; ++length, arglist = ffebld_trail (arglist))
  1048.     {
  1049.       if ((arg = ffebld_head (arglist)) == NULL)
  1050.     return FFEBAD_INTRINSIC_REF;
  1051.  
  1052.       info = ffebld_info (arg);
  1053.       if ((ffeinfo_basictype (info) != FFEINFO_basictypeLOGICAL)
  1054.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT)
  1055.       || (ffeinfo_rank (info) != 0)
  1056.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1057.     return FFEBAD_INTRINSIC_REF;
  1058.     }
  1059.  
  1060.   if (length < 2)
  1061.     return FFEBAD_INTRINSIC_TOOFEW;
  1062.  
  1063.   return FFEBAD;        /* Ok. */
  1064. }
  1065.  
  1066. #endif
  1067. static ffebad
  1068. ffeintrin_check_mvbits_ (ffebld arglist)
  1069. {
  1070.   ffebld arg1;
  1071.   ffebld arg2;
  1072.   ffebld arg3;
  1073.   ffebld arg4;
  1074.   ffebld arg5;
  1075.   ffeinfo info;
  1076.   ffebad bad;
  1077.  
  1078.   bad = ffeintrin_check_5_ (arglist, &arg1, &arg2, &arg3, &arg4, &arg5);
  1079.   if (bad != FFEBAD)
  1080.     return bad;
  1081.  
  1082.   info = ffebld_info (arg1);
  1083.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  1084.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  1085.       || (ffeinfo_rank (info) != 0)
  1086.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1087.     return FFEBAD_INTRINSIC_REF;
  1088.  
  1089.   info = ffebld_info (arg2);
  1090.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  1091.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  1092.       || (ffeinfo_rank (info) != 0)
  1093.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1094.     return FFEBAD_INTRINSIC_REF;
  1095.  
  1096.   info = ffebld_info (arg3);
  1097.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  1098.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  1099.       || (ffeinfo_rank (info) != 0)
  1100.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1101.     return FFEBAD_INTRINSIC_REF;
  1102.  
  1103.   info = ffebld_info (arg4);
  1104.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  1105.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  1106.       || (ffeinfo_rank (info) != 0)
  1107.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
  1108.       || ((ffebld_op (arg4) != FFEBLD_opSYMTER)
  1109.       && (ffebld_op (arg4) != FFEBLD_opARRAYREF)))
  1110.     return FFEBAD_INTRINSIC_REF;
  1111.  
  1112.   info = ffebld_info (arg5);
  1113.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeINTEGER)
  1114.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT)
  1115.       || (ffeinfo_rank (info) != 0)
  1116.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1117.     return FFEBAD_INTRINSIC_REF;
  1118.  
  1119.   return FFEBAD;        /* Ok. */
  1120. }
  1121.  
  1122. static ffebad
  1123. ffeintrin_check_procedure_ (ffeintrinImp imp, ffebldOp op)
  1124. {
  1125.   bool subr = (ffeintrin_imps_[imp].basictype == FFEINFO_basictypeNONE);
  1126.  
  1127.   if ((op == FFEBLD_opSUBRREF) && !subr)
  1128.     return FFEBAD_INTRINSIC_IS_FUNC;
  1129.  
  1130.   if ((op == FFEBLD_opFUNCREF) && subr)
  1131.     return FFEBAD_INTRINSIC_IS_SUBR;
  1132.  
  1133.   return FFEBAD;
  1134. }
  1135.  
  1136. static ffebad
  1137. ffeintrin_check_real_1_ (ffebld arglist)
  1138. {
  1139.   ffebld arg1;
  1140.   ffeinfo info;
  1141.   ffebad bad;
  1142.  
  1143.   bad = ffeintrin_check_1_ (arglist, &arg1);
  1144.   if (bad != FFEBAD)
  1145.     return bad;
  1146.  
  1147.   info = ffebld_info (arg1);
  1148.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1149.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1150.       || (ffeinfo_rank (info) != 0)
  1151.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1152.     return FFEBAD_INTRINSIC_REF;
  1153.  
  1154.   return FFEBAD;        /* Ok. */
  1155. }
  1156.  
  1157. static ffebad
  1158. ffeintrin_check_real_1or2_ (ffebld arglist)
  1159. {
  1160.   ffebld arg1;
  1161.   ffebld arg2;
  1162.   ffeinfo info;
  1163.   ffebad bad;
  1164.  
  1165.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  1166.   if (bad != FFEBAD)
  1167.     return bad;
  1168.  
  1169.   info = ffebld_info (arg1);
  1170.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1171.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1172.       || (ffeinfo_rank (info) != 0)
  1173.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1174.     return FFEBAD_INTRINSIC_REF;
  1175.  
  1176.   if (arg2 == NULL)
  1177.     return FFEBAD;        /* Ok. */
  1178.  
  1179.   info = ffebld_info (arg2);
  1180.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1181.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1182.       || (ffeinfo_rank (info) != 0)
  1183.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1184.     return FFEBAD_INTRINSIC_REF;
  1185.  
  1186.   return FFEBAD;        /* Ok. */
  1187. }
  1188.  
  1189. static ffebad
  1190. ffeintrin_check_real_2_ (ffebld arglist)
  1191. {
  1192.   ffebld arg1;
  1193.   ffebld arg2;
  1194.   ffeinfo info;
  1195.   ffebad bad;
  1196.  
  1197.   bad = ffeintrin_check_2_ (arglist, &arg1, &arg2);
  1198.   if (bad != FFEBAD)
  1199.     return bad;
  1200.  
  1201.   info = ffebld_info (arg1);
  1202.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1203.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1204.       || (ffeinfo_rank (info) != 0)
  1205.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1206.     return FFEBAD_INTRINSIC_REF;
  1207.  
  1208.   info = ffebld_info (arg2);
  1209.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1210.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1211.       || (ffeinfo_rank (info) != 0)
  1212.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1213.     return FFEBAD_INTRINSIC_REF;
  1214.  
  1215.   return FFEBAD;        /* Ok. */
  1216. }
  1217.  
  1218. static ffebad
  1219. ffeintrin_check_real_2p_ (ffebld arglist)
  1220. {
  1221.   ffebld arg;
  1222.   ffebldListLength length = 0;
  1223.   ffeinfo info;
  1224.  
  1225.   for (; arglist != NULL; ++length, arglist = ffebld_trail (arglist))
  1226.     {
  1227.       if ((arg = ffebld_head (arglist)) == NULL)
  1228.     return FFEBAD_INTRINSIC_REF;
  1229.  
  1230.       info = ffebld_info (arg);
  1231.       if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1232.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDEFAULT)
  1233.       || (ffeinfo_rank (info) != 0)
  1234.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1235.     return FFEBAD_INTRINSIC_REF;
  1236.     }
  1237.  
  1238.   if (length < 2)
  1239.     return FFEBAD_INTRINSIC_TOOFEW;
  1240.  
  1241.   return FFEBAD;        /* Ok. */
  1242. }
  1243.  
  1244. static ffebad
  1245. ffeintrin_check_realdbl_1_ (ffebld arglist)
  1246. {
  1247.   ffebld arg1;
  1248.   ffeinfo info;
  1249.   ffebad bad;
  1250.  
  1251.   bad = ffeintrin_check_1_ (arglist, &arg1);
  1252.   if (bad != FFEBAD)
  1253.     return bad;
  1254.  
  1255.   info = ffebld_info (arg1);
  1256.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1257.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1258.       || (ffeinfo_rank (info) != 0)
  1259.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1260.     return FFEBAD_INTRINSIC_REF;
  1261.  
  1262.   return FFEBAD;        /* Ok. */
  1263. }
  1264.  
  1265. static ffebad
  1266. ffeintrin_check_realdbl_1or2_ (ffebld arglist)
  1267. {
  1268.   ffebld arg1;
  1269.   ffebld arg2;
  1270.   ffeinfo info;
  1271.   ffebad bad;
  1272.  
  1273.   bad = ffeintrin_check_1or2_ (arglist, &arg1, &arg2);
  1274.   if (bad != FFEBAD)
  1275.     return bad;
  1276.  
  1277.   info = ffebld_info (arg1);
  1278.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1279.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1280.       || (ffeinfo_rank (info) != 0)
  1281.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1282.     return FFEBAD_INTRINSIC_REF;
  1283.  
  1284.   if (arg2 == NULL)
  1285.     return FFEBAD;        /* Ok. */
  1286.  
  1287.   info = ffebld_info (arg2);
  1288.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1289.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1290.       || (ffeinfo_rank (info) != 0)
  1291.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1292.     return FFEBAD_INTRINSIC_REF;
  1293.  
  1294.   return FFEBAD;        /* Ok. */
  1295. }
  1296.  
  1297. static ffebad
  1298. ffeintrin_check_realdbl_2_ (ffebld arglist)
  1299. {
  1300.   ffebld arg1;
  1301.   ffebld arg2;
  1302.   ffeinfo info;
  1303.   ffebad bad;
  1304.  
  1305.   bad = ffeintrin_check_2_ (arglist, &arg1, &arg2);
  1306.   if (bad != FFEBAD)
  1307.     return bad;
  1308.  
  1309.   info = ffebld_info (arg1);
  1310.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1311.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1312.       || (ffeinfo_rank (info) != 0)
  1313.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1314.     return FFEBAD_INTRINSIC_REF;
  1315.  
  1316.   info = ffebld_info (arg2);
  1317.   if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1318.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1319.       || (ffeinfo_rank (info) != 0)
  1320.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1321.     return FFEBAD_INTRINSIC_REF;
  1322.  
  1323.   return FFEBAD;        /* Ok. */
  1324. }
  1325.  
  1326. static ffebad
  1327. ffeintrin_check_realdbl_2p_ (ffebld arglist)
  1328. {
  1329.   ffebld arg;
  1330.   ffebldListLength length = 0;
  1331.   ffeinfo info;
  1332.  
  1333.   for (; arglist != NULL; ++length, arglist = ffebld_trail (arglist))
  1334.     {
  1335.       if ((arg = ffebld_head (arglist)) == NULL)
  1336.     return FFEBAD_INTRINSIC_REF;
  1337.  
  1338.       info = ffebld_info (arg);
  1339.       if ((ffeinfo_basictype (info) != FFEINFO_basictypeREAL)
  1340.       || (ffeinfo_kindtype (info) != FFEINFO_kindtypeREALDOUBLE)
  1341.       || (ffeinfo_rank (info) != 0)
  1342.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY))
  1343.     return FFEBAD_INTRINSIC_REF;
  1344.     }
  1345.  
  1346.   if (length < 2)
  1347.     return FFEBAD_INTRINSIC_TOOFEW;
  1348.  
  1349.   return FFEBAD;        /* Ok. */
  1350. }
  1351.  
  1352. static ffebad
  1353. ffeintrin_check_void_ (ffebld arglist)
  1354. {
  1355.   return FFEBAD;        /* Ok. */
  1356. }
  1357.  
  1358. /* Compare name to intrinsic's name.  Uses strcmp on arguments' names.    */
  1359.  
  1360. static int
  1361. ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
  1362. {
  1363.   char *uc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_uc;
  1364.   char *lc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_lc;
  1365.   char *ic = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_ic;
  1366.  
  1367.   return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic);
  1368. }
  1369.  
  1370. /* Return basic type of intrinsic implementation.  */
  1371.  
  1372. ffeinfoBasictype
  1373. ffeintrin_basictype (ffeintrinImp imp)
  1374. {
  1375.   assert (imp < FFEINTRIN_imp);
  1376.   return ffeintrin_imps_[imp].basictype;
  1377. }
  1378.  
  1379. /* Return family to which specific intrinsic belongs.  */
  1380.  
  1381. ffeintrinFamily
  1382. ffeintrin_family (ffeintrinSpec spec)
  1383. {
  1384.   if (spec >= FFEINTRIN_spec)
  1385.     return FALSE;
  1386.   return ffeintrin_specs_[spec].family;
  1387. }
  1388.  
  1389. /* Check and fill in info on func/subr ref node.
  1390.  
  1391.    ffebld expr;            // FUNCREF or SUBRREF with no info (caller
  1392.                 // gets it from the modified info structure).
  1393.    ffeinfo info;        // Already filled in, will be overwritten.
  1394.    ffelexToken token;        // Used for error message.
  1395.    ffeintrin_fulfill_generic (&expr, &info, token);
  1396.  
  1397.    Based on the generic id, figure out which specific procedure is meant and
  1398.    pick that one.  Else return an error, a la _specific.  */
  1399.  
  1400. void
  1401. ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
  1402. {
  1403.   ffebld symter;
  1404.   ffebldOp op;
  1405.   ffeintrinGen gen;
  1406.   ffeintrinSpec spec = FFEINTRIN_specNONE;
  1407.   ffeintrinImp imp;
  1408.   ffeintrinSpec tspec;
  1409.   ffebad error;
  1410.   bool any = FALSE;
  1411.   char *name = NULL;
  1412.   int i;
  1413.  
  1414.   op = ffebld_op (*expr);
  1415.   assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
  1416.   assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
  1417.  
  1418.   gen = ffebld_symter_generic (ffebld_left (*expr));
  1419.   assert (gen != FFEINTRIN_genNONE);
  1420.  
  1421.   imp = FFEINTRIN_impNONE;
  1422.   error = FFEBAD;
  1423.  
  1424.   for (i = 0;
  1425.        (i < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
  1426.        && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
  1427.        ++i)
  1428.     {
  1429.       ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
  1430.       ffeIntrinsicState state
  1431.       = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
  1432.       ffebad terror;
  1433.       char *tname;
  1434.  
  1435.       if (state == FFE_intrinsicstateDELETED)
  1436.     continue;
  1437.  
  1438.       if (timp == FFEINTRIN_impNONE)
  1439.     tname = ffeintrin_specs_[tspec].name;
  1440.       else
  1441.     tname = ffeintrin_imps_[timp].name;
  1442.  
  1443.       if (state == FFE_intrinsicstateDISABLED)
  1444.     terror = FFEBAD_INTRINSIC_DISABLED;
  1445.       else if (timp == FFEINTRIN_impNONE)
  1446.     terror = FFEBAD_INTRINSIC_UNIMPL;
  1447.       else
  1448.     {
  1449.       terror = ffeintrin_check_procedure_ (timp, ffebld_op (*expr));
  1450.       if (terror == FFEBAD)
  1451.         {
  1452.           any = ffeintrin_check_any_ (ffebld_right (*expr));
  1453.           if (!any)
  1454.         terror = (*ffeintrin_imps_[timp].check) (ffebld_right (*expr));
  1455.         }
  1456.       if (!any && (terror == FFEBAD) && (timp != imp))
  1457.         {
  1458.           if (imp != FFEINTRIN_impNONE)
  1459.         {
  1460.           ffebad_start (FFEBAD_INTRINSIC_AMBIG);
  1461.           ffebad_here (0, ffelex_token_where_line (t),
  1462.                    ffelex_token_where_column (t));
  1463.           ffebad_string (ffeintrin_gens_[gen].name);
  1464.           ffebad_string (ffeintrin_specs_[spec].name);
  1465.           ffebad_string (ffeintrin_specs_[tspec].name);
  1466.           ffebad_finish ();
  1467.         }
  1468.           else
  1469.         {
  1470.           imp = timp;
  1471.           spec = tspec;
  1472.           error = terror;
  1473.         }
  1474.         }
  1475.       else if (!any && (terror != FFEBAD))
  1476.         {            /* This error has precedence over others. */
  1477.           if ((error == FFEBAD_INTRINSIC_DISABLED)
  1478.           || (error == FFEBAD_INTRINSIC_UNIMPL))
  1479.         error = FFEBAD;
  1480.         }
  1481.     }
  1482.  
  1483.       if (!any && (error == FFEBAD))
  1484.     {
  1485.       error = terror;
  1486.       name = tname;
  1487.     }
  1488.     }
  1489.  
  1490.   if (any || (imp == FFEINTRIN_impNONE))
  1491.     {
  1492.       if (!any)
  1493.     {
  1494.       if (error == FFEBAD)
  1495.         error = FFEBAD_INTRINSIC_REF;
  1496.       if (name == NULL)
  1497.         name = ffeintrin_gens_[gen].name;
  1498.       ffebad_start (error);
  1499.       ffebad_here (0, ffelex_token_where_line (t),
  1500.                ffelex_token_where_column (t));
  1501.       ffebad_string (name);
  1502.       ffebad_finish ();
  1503.     }
  1504.  
  1505.       *expr = ffebld_new_any ();
  1506.       *info = ffeinfo_new_any ();
  1507.     }
  1508.   else
  1509.     {
  1510.       *info = ffeinfo_new (ffeintrin_imps_[imp].basictype,
  1511.                ffeintrin_imps_[imp].kindtype,
  1512.                0,
  1513.                FFEINFO_kindENTITY,
  1514.                FFEINFO_whereFLEETING,
  1515.                ffeintrin_imps_[imp].size);
  1516.       symter = ffebld_left (*expr);
  1517.       ffebld_symter_set_specific (symter, spec);
  1518.       ffebld_symter_set_implementation (symter, imp);
  1519.       ffebld_set_info (symter,
  1520.                ffeinfo_new (ffeintrin_imps_[imp].basictype,
  1521.                     ffeintrin_imps_[imp].kindtype,
  1522.                     0,
  1523.                     (ffeintrin_imps_[imp].basictype
  1524.                      == FFEINFO_basictypeNONE)
  1525.                     ? FFEINFO_kindSUBROUTINE
  1526.                     : FFEINFO_kindFUNCTION,
  1527.                     FFEINFO_whereINTRINSIC,
  1528.                     ffeintrin_imps_[imp].size));
  1529.     }
  1530. }
  1531.  
  1532. /* Check and fill in info on func/subr ref node.
  1533.  
  1534.    ffebld expr;            // FUNCREF or SUBRREF with no info (caller
  1535.                 // gets it from the modified info structure).
  1536.    ffeinfo info;        // Already filled in, will be overwritten.
  1537.    ffelexToken token;        // Used for error message.
  1538.    ffeintrin_fulfill_specific (&expr, &info, token);
  1539.  
  1540.    Based on the specific id, determine whether the arg list is valid
  1541.    (number, type, rank, and kind of args) and fill in the info structure
  1542.    accordingly.     Currently don't rewrite the expression, but perhaps
  1543.    someday do so for constant collapsing, except when an error occurs,
  1544.    in which case it is overwritten with ANY and info is also overwritten
  1545.    accordingly.     */
  1546.  
  1547. void
  1548. ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info, ffelexToken t)
  1549. {
  1550.   ffebld symter;
  1551.   ffebldOp op;
  1552.   ffeintrinSpec spec;
  1553.   ffeintrinImp imp;
  1554.   ffeIntrinsicState state;
  1555.   ffebad error;
  1556.   bool any = FALSE;
  1557.  
  1558.   op = ffebld_op (*expr);
  1559.   assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
  1560.   assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
  1561.  
  1562.   spec = ffebld_symter_specific (ffebld_left (*expr));
  1563.   assert (spec != FFEINTRIN_specNONE);
  1564.  
  1565.   state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
  1566.  
  1567.   imp = ffeintrin_specs_[spec].implementation;
  1568.  
  1569.   if (state == FFE_intrinsicstateDISABLED)
  1570.     error = FFEBAD_INTRINSIC_DISABLED;
  1571.   else if (imp == FFEINTRIN_impNONE)
  1572.     error = FFEBAD_INTRINSIC_UNIMPL;
  1573.   else
  1574.     {
  1575.       error = ffeintrin_check_procedure_ (imp, ffebld_op (*expr));
  1576.       if (error == FFEBAD)
  1577.     {
  1578.       any = ffeintrin_check_any_ (ffebld_right (*expr));
  1579.       if (!any)
  1580.         error = (*ffeintrin_imps_[imp].check) (ffebld_right (*expr));
  1581.     }
  1582.     }
  1583.  
  1584.   if (any || (error != FFEBAD))
  1585.     {
  1586.       char *name;
  1587.  
  1588.       if (!any)
  1589.     {
  1590.       ffebad_start (error);
  1591.       ffebad_here (0, ffelex_token_where_line (t),
  1592.                ffelex_token_where_column (t));
  1593.       if (imp == FFEINTRIN_impNONE)
  1594.         name = ffeintrin_specs_[spec].name;
  1595.       else
  1596.         name = ffeintrin_imps_[imp].name;
  1597.       ffebad_string (name);
  1598.       ffebad_finish ();
  1599.     }
  1600.  
  1601.       *expr = ffebld_new_any ();
  1602.       *info = ffeinfo_new_any ();
  1603.     }
  1604.   else
  1605.     {
  1606.       *info = ffeinfo_new (ffeintrin_imps_[imp].basictype,
  1607.                ffeintrin_imps_[imp].kindtype,
  1608.                0,
  1609.                FFEINFO_kindENTITY,
  1610.                FFEINFO_whereFLEETING,
  1611.                ffeintrin_imps_[imp].size);
  1612.       symter = ffebld_left (*expr);
  1613.       ffebld_set_info (symter,
  1614.                ffeinfo_new (ffeintrin_imps_[imp].basictype,
  1615.                     ffeintrin_imps_[imp].kindtype,
  1616.                     0,
  1617.                     (ffeintrin_imps_[imp].basictype
  1618.                      == FFEINFO_basictypeNONE)
  1619.                     ? FFEINFO_kindSUBROUTINE
  1620.                     : FFEINFO_kindFUNCTION,
  1621.                     FFEINFO_whereINTRINSIC,
  1622.                     ffeintrin_imps_[imp].size));
  1623.     }
  1624. }
  1625.  
  1626. /* Return run-time index of intrinsic implementation as arg.  */
  1627.  
  1628. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1629. ffecomGfrt
  1630. ffeintrin_gfrt (ffeintrinImp imp)
  1631. {
  1632.   assert (imp < FFEINTRIN_imp);
  1633.   return ffeintrin_imps_[imp].gfrt;
  1634. }
  1635.  
  1636. #endif
  1637. void
  1638. ffeintrin_init_0 ()
  1639. {
  1640.   int i;
  1641.   char *p1;
  1642.   char *p2;
  1643.   char *p3;
  1644.  
  1645.   assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
  1646.   assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
  1647.   assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
  1648.  
  1649.   for (i = 1; i < ARRAY_SIZE (ffeintrin_names_); ++i)
  1650.     {                /* Make sure binary-searched list is in alpha
  1651.                    order. */
  1652.       if (strcmp (ffeintrin_names_[i - 1].name_uc,
  1653.           ffeintrin_names_[i].name_uc) >= 0)
  1654.     assert ("name list out of order" == NULL);
  1655.     }
  1656.  
  1657.   for (i = 0; i < ARRAY_SIZE (ffeintrin_names_); ++i)
  1658.     {
  1659.       p1 = ffeintrin_names_[i].name_uc;
  1660.       p2 = ffeintrin_names_[i].name_lc;
  1661.       p3 = ffeintrin_names_[i].name_ic;
  1662.       for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
  1663.     {
  1664.       if (!isascii (*p1) || !isascii (*p2) || !isascii (*p3))
  1665.         break;
  1666.       if ((isdigit (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
  1667.         continue;
  1668.       if (!isupper (*p1) || !islower (*p2)
  1669.           || (*p1 != toupper (*p2)) || ((*p3 != *p1) && (*p3 != *p2)))
  1670.         break;
  1671.     }
  1672.       assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
  1673.     }
  1674. }
  1675.  
  1676. /* Determine whether intrinsic ok as actual arg.  */
  1677.  
  1678. bool
  1679. ffeintrin_is_actualarg (ffeintrinSpec spec)
  1680. {
  1681.   ffeIntrinsicState state;
  1682.  
  1683.   if (spec >= FFEINTRIN_spec)
  1684.     return FALSE;
  1685.  
  1686.   state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
  1687.  
  1688.   return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
  1689. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1690.     && (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt
  1691.     != FFECOM_gfrt)
  1692. #endif
  1693.     && ((state == FFE_intrinsicstateENABLED)
  1694.     || (state == FFE_intrinsicstateHIDDEN));
  1695. }
  1696.  
  1697. /* Determine if name is intrinsic, return info.
  1698.  
  1699.    char *name;            // C-string name of possible intrinsic.
  1700.    ffelexToken t;        // NULL if no diagnostic to be given.
  1701.    bool explicit;        // TRUE if INTRINSIC name.
  1702.    ffeintrinGen gen;        // (TRUE only) Generic id of intrinsic.
  1703.    ffeintrinSpec spec;        // (TRUE only) Specific id of intrinsic.
  1704.    ffeintrinImp imp;        // (TRUE only) Implementation id of intrinsic.
  1705.    ffeinfoKind kind;        // (TRUE:) kindFUNCTION, kindSUBROUTINE,
  1706.                 // or kindNONE; (FALSE:) kindANY, kindNONE.
  1707.    if (ffeintrin_is_intrinsic (name, t, &gen, &spec, &imp, &kind))
  1708.                 // is an intrinsic, use gen, spec, imp, and
  1709.                 // kind accordingly.
  1710.  
  1711.    If FALSE is returned, kindANY says that the intrinsic exists but is
  1712.    not valid for some reason (disabled or unimplemented), in which case a
  1713.    diagnostic was generated (assuming t == NULL).  */
  1714.  
  1715. bool
  1716. ffeintrin_is_intrinsic (char *name, ffelexToken t, bool explicit,
  1717.             ffeintrinGen *xgen, ffeintrinSpec *xspec,
  1718.             ffeintrinImp *ximp, ffeinfoKind *xkind)
  1719. {
  1720.   struct _ffeintrin_name_ *intrinsic;
  1721.   ffeintrinGen gen;
  1722.   ffeintrinSpec spec;
  1723.   ffeintrinImp imp;
  1724.   ffeinfoKind kind;
  1725.   ffeIntrinsicState state;
  1726.   bool disabled = FALSE;
  1727.   bool unimpl = FALSE;
  1728.  
  1729.   intrinsic = bsearch (name, &ffeintrin_names_[0],
  1730.                ARRAY_SIZE (ffeintrin_names_),
  1731.                sizeof (struct _ffeintrin_name_),
  1732.                  (void *) ffeintrin_cmp_name_);
  1733.  
  1734.   if (intrinsic == NULL)
  1735.     return FALSE;
  1736.  
  1737.   gen = intrinsic->generic;
  1738.   spec = intrinsic->specific;
  1739.   imp = ffeintrin_specs_[spec].implementation;
  1740.  
  1741.   /* Generic is okay only if at least one of its specifics is okay.  */
  1742.  
  1743.   if (gen != FFEINTRIN_genNONE)
  1744.     {
  1745.       int i;
  1746.       ffeintrinSpec tspec;
  1747.       bool ok = FALSE;
  1748.  
  1749.       for (i = 0;
  1750.        (i < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
  1751.        && ((tspec
  1752.         = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
  1753.        ++i)
  1754.     {
  1755.       state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
  1756.  
  1757.       if (state == FFE_intrinsicstateDELETED)
  1758.         continue;
  1759.  
  1760.       if (state == FFE_intrinsicstateDISABLED)
  1761.         {
  1762.           disabled = TRUE;
  1763.           continue;
  1764.         }
  1765.  
  1766.       if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
  1767.         {
  1768.           unimpl = TRUE;
  1769.           continue;
  1770.         }
  1771.  
  1772.       if ((state == FFE_intrinsicstateENABLED)
  1773.           || (explicit
  1774.           && (state == FFE_intrinsicstateHIDDEN)))
  1775.         {
  1776.           ok = TRUE;
  1777.           break;
  1778.         }
  1779.     }
  1780.       if (!ok)
  1781.     gen = FFEINTRIN_genNONE;
  1782.     }
  1783.  
  1784.   /* Specific is okay only if not: unimplemented, disabled, deleted, or
  1785.      hidden and not explicit.  */
  1786.  
  1787.   if (spec != FFEINTRIN_specNONE)
  1788.     {
  1789.       if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
  1790.        == FFE_intrinsicstateDELETED)
  1791.       || (!explicit
  1792.           && (state == FFE_intrinsicstateHIDDEN)))
  1793.     spec = FFEINTRIN_specNONE;
  1794.       else if (state == FFE_intrinsicstateDISABLED)
  1795.     {
  1796.       disabled = TRUE;
  1797.       spec = FFEINTRIN_specNONE;
  1798.     }
  1799.       else if (imp == FFEINTRIN_impNONE)
  1800.     {
  1801.       unimpl = TRUE;
  1802.       spec = FFEINTRIN_specNONE;
  1803.     }
  1804.     }
  1805.  
  1806.   /* If neither is okay, not an intrinsic.  */
  1807.  
  1808.   if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
  1809.     {
  1810.       /* Here is where we produce a diagnostic about a reference to a
  1811.          disabled or unimplemented intrinsic, if the diagnostic is desired.  */
  1812.  
  1813.       if ((disabled || unimpl)
  1814.       && (t != NULL))
  1815.     {
  1816.       ffebad_start (disabled
  1817.             ? FFEBAD_INTRINSIC_DISABLED
  1818.             : FFEBAD_INTRINSIC_UNIMPL);
  1819.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  1820.       ffebad_string (name);
  1821.       ffebad_finish ();
  1822.     }
  1823.  
  1824.       if (disabled || unimpl)
  1825.     *xkind = FFEINFO_kindANY;
  1826.       else
  1827.     *xkind = FFEINFO_kindNONE;
  1828.       return FALSE;
  1829.     }
  1830.  
  1831.   /* Determine whether intrinsic is function or subroutine.  If no specific
  1832.      id, scan list of possible specifics for generic to get consensus.  Must
  1833.      be unanimous, at least for now.  */
  1834.  
  1835.   if (spec == FFEINTRIN_specNONE)
  1836.     {
  1837.       int i;
  1838.       ffeintrinSpec tspec;
  1839.       ffeintrinImp timp;
  1840.       ffeinfoKind tkind;
  1841.  
  1842.       kind = FFEINFO_kindNONE;
  1843.  
  1844.       for (i = 0;
  1845.        (i < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
  1846.        && ((tspec
  1847.         = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
  1848.        ++i)
  1849.     {
  1850.       if ((timp = ffeintrin_specs_[tspec].implementation)
  1851.           == FFEINTRIN_impNONE)
  1852.         continue;
  1853.  
  1854.       if (ffeintrin_imps_[timp].basictype == FFEINFO_basictypeNONE)
  1855.         tkind = FFEINFO_kindSUBROUTINE;
  1856.       else
  1857.         tkind = FFEINFO_kindFUNCTION;
  1858.  
  1859.       if ((kind == tkind) || (kind == FFEINFO_kindNONE))
  1860.         kind = tkind;
  1861.       else
  1862.         assert ("what kind of proc am i?" == NULL);
  1863.     }
  1864.     }
  1865.   else                /* Have specific, use that. */
  1866.     kind
  1867.       = (ffeintrin_imps_[imp].basictype == FFEINFO_basictypeNONE)
  1868.       ? FFEINFO_kindSUBROUTINE
  1869.       : FFEINFO_kindFUNCTION;
  1870.  
  1871.   *xgen = gen;
  1872.   *xspec = spec;
  1873.   *ximp = imp;
  1874.   *xkind = kind;
  1875.   return TRUE;
  1876. }
  1877.  
  1878. /* Return kind type of intrinsic implementation.  */
  1879.  
  1880. ffeinfoKindtype
  1881. ffeintrin_kindtype (ffeintrinImp imp)
  1882. {
  1883.   assert (imp < FFEINTRIN_imp);
  1884.   return ffeintrin_imps_[imp].kindtype;
  1885. }
  1886.  
  1887. /* Return name of generic intrinsic.  */
  1888.  
  1889. char *
  1890. ffeintrin_name_generic (ffeintrinGen gen)
  1891. {
  1892.   assert (gen < FFEINTRIN_gen);
  1893.   return ffeintrin_gens_[gen].name;
  1894. }
  1895.  
  1896. /* Return name of intrinsic implementation.  */
  1897.  
  1898. char *
  1899. ffeintrin_name_implementation (ffeintrinImp imp)
  1900. {
  1901.   assert (imp < FFEINTRIN_imp);
  1902.   return ffeintrin_imps_[imp].name;
  1903. }
  1904.  
  1905. /* Return external/internal name of specific intrinsic.     */
  1906.  
  1907. char *
  1908. ffeintrin_name_specific (ffeintrinSpec spec)
  1909. {
  1910.   assert (spec < FFEINTRIN_spec);
  1911.   return ffeintrin_specs_[spec].name;
  1912. }
  1913.  
  1914. /* Return state of family.  */
  1915.  
  1916. ffeIntrinsicState
  1917. ffeintrin_state_family (ffeintrinFamily family)
  1918. {
  1919.   ffeIntrinsicState state;
  1920.  
  1921.   switch (family)
  1922.     {
  1923.     case FFEINTRIN_familyNONE:
  1924.       return FFE_intrinsicstateDELETED;
  1925.  
  1926.     case FFEINTRIN_familyF77:
  1927.       return FFE_intrinsicstateENABLED;
  1928.  
  1929.     case FFEINTRIN_familyASC:
  1930.       state = ffe_intrinsic_state_f2c ();
  1931.       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
  1932.       return state;
  1933.  
  1934.     case FFEINTRIN_familyMIL:
  1935.       state = ffe_intrinsic_state_vxt ();
  1936.       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
  1937.       state = ffe_state_max (state, ffe_intrinsic_state_mil ());
  1938.       return state;
  1939.  
  1940.     case FFEINTRIN_familyDCP:
  1941.       state = ffe_intrinsic_state_vxt ();
  1942.       state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
  1943.       state = ffe_state_max (state, ffe_intrinsic_state_dcp ());
  1944.       return state;
  1945.  
  1946.     case FFEINTRIN_familyF90:
  1947.       state = ffe_intrinsic_state_f90 ();
  1948.       return state;
  1949.  
  1950.     case FFEINTRIN_familyVXT:
  1951.       state = ffe_intrinsic_state_vxt ();
  1952.       return state;
  1953.  
  1954.     case FFEINTRIN_familyFVZ:
  1955.       state = ffe_intrinsic_state_f2c ();
  1956.       state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
  1957.       state = ffe_state_max (state, ffe_intrinsic_state_dcp ());
  1958.       return state;
  1959.  
  1960.     case FFEINTRIN_familyF2C:
  1961.       state = ffe_intrinsic_state_f2c ();
  1962.       return state;
  1963.  
  1964.     case FFEINTRIN_familyF2Z:
  1965.       state = ffe_intrinsic_state_f2c ();
  1966.       return state;
  1967.  
  1968.     default:
  1969.       assert ("bad family" == NULL);
  1970.       return FFE_intrinsicstateDELETED;
  1971.     }
  1972. }
  1973.